├── LICENSE ├── README.md ├── bin ├── install.sh └── scheme-env.scm ├── lib └── tools.scm └── scripts ├── command-line.scm ├── command-line ├── chez.scm ├── gauche.scm ├── larceny.scm └── sagittarius.scm ├── host-update.scm ├── install.scm ├── install ├── chez.scm ├── chibi-scheme.scm ├── chicken-scheme.scm ├── foment.scm ├── gauche.scm ├── guile.scm ├── larceny.scm └── sagittarius.scm ├── invalidate.scm ├── list.scm ├── remove.scm ├── run.scm ├── sitelib.scm └── switch.scm /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 2-Clause License 2 | 3 | Copyright (c) 2018-2020, Takashi Kato 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Scheme environment 2 | 3 | This will be a simple Scheme implementation switcher. 4 | 5 | # How to install 6 | 7 | ``` 8 | $ curl https://raw.githubusercontent.com/ktakashi/scheme-env/master/bin/install.sh | bash 9 | ``` 10 | 11 | After the installation you need to add the following to your shell 12 | resource file: 13 | 14 | ``` 15 | PATH=~/.scheme-env/bin:$PATH 16 | ``` 17 | 18 | # How to use 19 | 20 | The basic command id `scheme-env` if you want to run the default 21 | implementation then use the following comment 22 | 23 | ``` 24 | $ scheme-env run 25 | ``` 26 | 27 | # Installing implementations 28 | 29 | To install implementations, you can run the following command 30 | 31 | ``` 32 | $ scheme-env install implementation 33 | ``` 34 | Currently the followings are the supported implementation 35 | 36 | - Chibi Scheme (chibi-scheme) 37 | - Sagittarius Scheme (sagittarius) 38 | - Gauche (gauche) 39 | - Foment (foment) 40 | - Chicken (chicken-scheme) 41 | - Larceny (larceny) 42 | - Chez Scheme (chez) 43 | 44 | You can also specify the version by adding `@` and version number. 45 | For example: 46 | 47 | ``` 48 | $ scheme-env install sagittarius@0.8.9 49 | ``` 50 | 51 | ## For Chicken Scheme 52 | 53 | The installation process of Chicken Scheme creates 3 aliases, `csi`, `csc` and 54 | `chicken-scheme` followed by `@{version}` suffix. These are the standard 55 | entry points for Chicken Scheme. 56 | 57 | ## macOS 58 | 59 | On macOS, there are following prerequisites: 60 | 61 | - Installing Xcode (For Chicken Scheme) 62 | - Installing [XQuartz](https://www.xquartz.org/) (For Chez Scheme) 63 | 64 | # Switch implementations 65 | 66 | To swich default implementation, you can run the following command 67 | 68 | ``` 69 | $ scheme-env switch implementation 70 | ``` 71 | If this command isn't run, then `sagitarius` is set to default. 72 | 73 | # Run specific implementation 74 | 75 | To run an installed implementation, you can run the following command 76 | 77 | ``` 78 | $ scheme-env run implementation 79 | ``` 80 | 81 | # Acknowledgement 82 | 83 | * Shiro Kawai for the installation script of Gauche 84 | -------------------------------------------------------------------------------- /bin/install.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -o pipefail 4 | 5 | # installing host Scheme implementation (latest Sagittarius) and scheme env 6 | SCHEME_ENV_INSTALL_PACKAGE=${SCHEME_ENV_INSTALL_PACKAGE:-"yes"} 7 | 8 | stop() 9 | { 10 | while true; do 11 | read -rep $'\nAre you sure you want to stop? (y/n)' yn 12 | case $yn in 13 | [Yy]*) exit 1;; 14 | [Nn]*) break ;; 15 | *) echo 'Please enter (y/n)';; 16 | esac 17 | done 18 | } 19 | trap 'stop' SIGINT 20 | 21 | SCHEME_ENV_HOME=~/.scheme-env 22 | mkdir -p ${SCHEME_ENV_HOME}/bin 23 | mkdir -p ${SCHEME_ENV_HOME}/sitelib 24 | mkdir -p ${SCHEME_ENV_HOME}/metainf 25 | mkdir -p ${SCHEME_ENV_HOME}/scripts 26 | mkdir -p ${SCHEME_ENV_HOME}/implementations 27 | mkdir -p ${SCHEME_ENV_HOME}/work 28 | mkdir -p ${SCHEME_ENV_HOME}/tmp 29 | 30 | cd ${SCHEME_ENV_HOME} 31 | 32 | # directories are created. so install host implementation 33 | 34 | ubuntu_package() 35 | { 36 | name=$1 37 | echo -n "Checking package '${name}' ... " 38 | installed=`dpkg --get-selections | grep ${name}` 39 | if [ $? -ne 0 ]; then 40 | echo "Installing package ${name}" 41 | sudo apt-get install ${name} 42 | else 43 | echo 'ok' 44 | fi 45 | } 46 | 47 | msys2_package() 48 | { 49 | name=$1 50 | # fixup some of the names 51 | case $name in 52 | libffi*) name=libffi;; 53 | libgc*) name=libgc;; 54 | zlib1g*) name=zlib-devel;; 55 | libssl*) name=openssl-devel;; 56 | g++) return 0;; 57 | esac 58 | pacman --noconfirm -S --noprogressbar --needed ${name} 59 | } 60 | 61 | linux_command() 62 | { 63 | LINUX_DISTRIBUTION=`lsb_release -i` 64 | case ${LINUX_DISTRIBUTION} in 65 | *Ubuntu*) 66 | PACKAGE_COMMAND='ubuntu_package' 67 | ;; 68 | *) 69 | echo "${LINUX_DISTRIBUTION} is not supported yet" 70 | exit 1 71 | ;; 72 | esac 73 | } 74 | 75 | msys2_command() 76 | { 77 | PACKAGE_COMMAND='msys2_package' 78 | # a bit of abuse but hey 79 | tmpfile=$(mktemp /tmp/symlink_test.XXXXXX) 80 | symlink=${tmpfile}.sym 81 | MUST_RESTORE=yes 82 | RESTORING_ENVIROMNENT_VARIABLE=`printenv MSYS` 83 | for v in 'winsymlinks:native' 'winsymlinks:lnk' 84 | do 85 | export MSYS= 86 | export MSYS=${v} 87 | if [ -e ${symlink} ]; then 88 | rm ${symlink} 89 | fi 90 | # check 91 | ln -s ${tmpfile} ${symlink} 92 | if [ -h ${symlink} ]; then 93 | break; 94 | fi 95 | done 96 | rm ${tmpfile} ${symlink} 97 | } 98 | 99 | install_package() 100 | { 101 | for name in $@ 102 | do 103 | ${PACKAGE_COMMAND} ${name} 104 | done 105 | } 106 | 107 | init_commands() { 108 | PLATFORM_OS=`uname -s` 109 | case ${PLATFORM_OS} in 110 | Linux) linux_command ;; 111 | *MSYS*) msys2_command ;; 112 | *) 113 | echo "************************WARNING*************************" 114 | echo "* Package manager of '${PLATFORM_OS}' is not supported.*" 115 | echo "* So required package must manually be installed. *" 116 | echo "********************************************************" 117 | SCHEME_ENV_INSTALL_PACKAGE=no 118 | ;; 119 | esac 120 | case ${PLATFORM_OS} in 121 | Darwin) LD_LIBRARY_PATH_NAME=DYLD_LIBRARY_PATH ;; 122 | *) LD_LIBRARY_PATH_NAME=LD_LIBRARY_PATH ;; 123 | esac 124 | } 125 | 126 | usage() 127 | { 128 | echo <&2 129 | install.sh [-l] 130 | -l, Using local files instead of Github (for developers) 131 | EOF 132 | exit 1 133 | } 134 | 135 | while getopts "l:" o; do 136 | case "${o}" in 137 | l) 138 | USE_LOCAL=yes 139 | LOCAL_REPOSITORY=${OPTARG} 140 | ;; 141 | *) 142 | usage 143 | ;; 144 | esac 145 | done 146 | shift $((OPTIND-1)) 147 | 148 | init_commands 149 | echo "Should install packages ... ${SCHEME_ENV_INSTALL_PACKAGE}" 150 | case ${SCHEME_ENV_INSTALL_PACKAGE} in 151 | 1|yes) 152 | # TODO absorb the different names 153 | install_package gcc g++ make curl cmake libgc-dev \ 154 | libffi-dev zlib1g-dev libssl-dev 155 | ;; 156 | esac 157 | 158 | check_downloader() 159 | { 160 | # curl first, then wget 161 | echo -n "Checking curl ... " 162 | c=`command -v curl` 163 | if [ $? -eq 0 ]; then 164 | echo "yes" 165 | CURL="curl -sL -o" 166 | else 167 | echo "no" 168 | echo -n "Checking wget ... " 169 | c=`command -v wget` 170 | if [ $? -eq 0 ]; then 171 | echo "yes" 172 | CURL="wget -q -O" 173 | else 174 | echo "no" 175 | echo "curl or wget is required" 176 | exit 1 177 | fi 178 | fi 179 | } 180 | check_downloader 181 | 182 | REPOSITORY_URL=https://bitbucket.org/ktakashi/sagittarius-scheme/downloads 183 | 184 | echo -n "Downloading latest-version.txt ... " 185 | ${CURL} work/version ${REPOSITORY_URL}/latest-version.txt 186 | echo "done!" 187 | 188 | VERSION=`cat work/version` 189 | echo "Host Sagittarius version ... ${VERSION}" 190 | 191 | SAGITTARIUS_DIR=$SCHEME_ENV_HOME/implementations/sagittarius 192 | INSTALL_DIR=${SAGITTARIUS_DIR}/${VERSION} 193 | 194 | SKIP_HOST_INSTALL=no 195 | installed_version=no 196 | if [ -f ${SCHEME_ENV_HOME}/bin/host-scheme ]; then 197 | installed_version=`${SCHEME_ENV_HOME}/bin/host-scheme -v` 198 | elif [ -d ${SCHEME_ENV_HOME}/implementations/sagittarius/${VERSION} ]; then 199 | installed_version=`${SCHEME_ENV_HOME}/implementations/sagittarius/${VERSION}/bin/sagittarius -v` 200 | fi 201 | 202 | echo "Installed version: ${installed_version}" 203 | case ${installed_version} in 204 | *${VERSION}*) SKIP_HOST_INSTALL=yes ;; 205 | *) ;; 206 | esac 207 | 208 | progress() 209 | { 210 | first=1 211 | indicator='|' 212 | msg=$1 213 | while read line; do 214 | progres_regex='\[(.*)%\].*' 215 | install_regex='^--.*:.*' 216 | if [[ ${line} =~ ${progres_regex} ]]; then 217 | percent=${BASH_REMATCH[1]} 218 | let count=percent/10 219 | echo -ne "${msg} ... #" 220 | i=0 221 | while [ $i -lt $count ]; do 222 | echo -ne '###' 223 | let i++ 224 | done 225 | while [ $i -lt 10 ]; do 226 | echo -ne ' ' 227 | let i++ 228 | done 229 | echo -ne " (${percent}%)\r" 230 | elif [[ ${line} =~ ${install_regex} ]]; then 231 | if [ ${first} -eq 1 ]; then 232 | echo -ne '\n' 233 | first=0 234 | fi 235 | echo -ne "Installing files ... ${indicator}\r" 236 | if [ x"${indicator}" == x"|" ]; then 237 | indicator='-' 238 | else 239 | indicator='|' 240 | fi 241 | fi 242 | done 243 | if [ ${first} -eq 1 ]; then 244 | echo -ne "\n" 245 | else 246 | echo "Installing files ... done!" 247 | fi 248 | } 249 | 250 | check_status() 251 | { 252 | if [ $? -ne 0 ]; then 253 | tail -n 20 build.log 254 | exit -1 255 | fi 256 | } 257 | 258 | install_host_scheme() 259 | { 260 | echo -n "Downloading Sagittarius ${VERSION} ... " 261 | LATEST_TAR=sagittarius-${VERSION}.tar.gz 262 | ${CURL} work/${LATEST_TAR} ${REPOSITORY_URL}/${LATEST_TAR} 263 | echo "done!" 264 | 265 | cd work 266 | echo -n "Expanding Sagittarius $VERSION ... " 267 | tar xf ${LATEST_TAR} 268 | echo "done!" 269 | 270 | cd sagittarius-${VERSION} 271 | echo -n "Pre-build process ... " 272 | cmake -DCMAKE_INSTALL_PREFIX=${INSTALL_DIR} . > build.log 2>&1 273 | echo "done!" 274 | 275 | make -j8 2>&1 | tee -a build.log | progress "Building host Sagittarius " 276 | check_status 277 | make install 2>&1| tee -a build.log | progress "Installing host Sagittarius" 278 | check_status 279 | 280 | HOST_SCHEME=`pwd` 281 | # back to work 282 | cd .. 283 | case `uname -s` in 284 | *CYGWIN*) 285 | make rebase > /dev/null 2>&1 286 | echo "****************************************************" 287 | echo "* PLEASE EXECUTE /bin/rebaseall -v -T dlls.txt *" 288 | echo "****************************************************" 289 | echo "Command on Ash (or Dash)" 290 | echo "cd ${HOST_SCHEME}; /bin/rebaseall -v -T dlls.txt" 291 | echo "Reinstall command" 292 | echo "cd ${HOST_SCHEME}; make install" 293 | ;; 294 | *) 295 | # remove work 296 | rm -rf * 297 | esac 298 | } 299 | 300 | case ${SKIP_HOST_INSTALL} in 301 | yes) echo "The latest host Sagittarius is installed so skip" ;; 302 | no) install_host_scheme ;; 303 | esac 304 | 305 | remove_if_exists() 306 | { 307 | for file in "$@" 308 | do 309 | if [ -e ${file} ]; then 310 | rm -rf ${file} 311 | fi 312 | done 313 | } 314 | 315 | remove_if_exists ${INSTALL_DIR}/sagittarius ${SCHEME_ENV_HOME}/bin/sagittarius 316 | 317 | echo -n "Creating symblic links ... " 318 | cat << EOF > ${INSTALL_DIR}/sagittarius 319 | #!/bin/sh 320 | exec env ${LD_LIBRARY_PATH_NAME}=${INSTALL_DIR}/lib ${INSTALL_DIR}/bin/sagittarius "\$@" 321 | EOF 322 | 323 | chmod +x ${INSTALL_DIR}/sagittarius 324 | 325 | remove_if_exists ${SCHEME_ENV_HOME}/bin/default \ 326 | ${SCHEME_ENV_HOME}/bin/host-scheme 327 | 328 | LINK_NAME=${SCHEME_ENV_HOME}/bin/sagittarius@${VERSION} 329 | 330 | remove_if_exists ${LINK_NAME} 331 | 332 | ln -s ${INSTALL_DIR}/sagittarius ${LINK_NAME} 333 | ln -s ${LINK_NAME} ${SCHEME_ENV_HOME}/bin/default 334 | ln -s ${LINK_NAME} ${SCHEME_ENV_HOME}/bin/host-scheme 335 | echo "done!" 336 | 337 | case ${MUST_RESTORE} in 338 | yes) 339 | export MSYS= 340 | export MSYS=${RESTORING_ENVIROMNENT_VARIABLE} 341 | ;; 342 | esac 343 | 344 | cd ${SCHEME_ENV_HOME} 345 | 346 | echo -n "Installing execution script ... " 347 | cat < bin/scheme-env 348 | #!/bin/sh 349 | exec env SCHEME_ENV_HOME=${SCHEME_ENV_HOME} \ 350 | ${SCHEME_ENV_HOME}/bin/host-scheme \ 351 | ${SCHEME_ENV_HOME}/bin/scheme-env.scm "\$@" 352 | EOF 353 | 354 | chmod +x bin/scheme-env 355 | echo "done!" 356 | 357 | case ${USE_LOCAL} in 358 | yes) 359 | cp ${LOCAL_REPOSITORY}/bin/scheme-env.scm bin/scheme-env.scm 360 | ;; 361 | *) 362 | ${CURL} bin/scheme-env.scm https://raw.githubusercontent.com/ktakashi/scheme-env/master/bin/scheme-env.scm 363 | ;; 364 | esac 365 | 366 | cat < 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!read-macro=sagittarius/regex 32 | (import (rnrs) 33 | (rnrs eval) 34 | (sagittarius) 35 | (sagittarius regex) 36 | (scheme load) 37 | (rfc http) 38 | (util file)) 39 | 40 | ;; a bit of duplication 41 | (define-constant +default-github-repository+ 42 | "https://raw.githubusercontent.com/ktakashi/scheme-env/master") 43 | (define scheme-env-repository 44 | (cond ((getenv "SCHEME_ENV_REPOSITORY")) 45 | (else +default-github-repository+))) 46 | (define scheme-env-home 47 | (or (getenv "SCHEME_ENV_HOME") 48 | (assertion-violation 'scheme-env-home "SCHEME_ENV_HOME is not set"))) 49 | 50 | (define (load-tools-library) 51 | (define destination-directory (build-path scheme-env-home "lib")) 52 | (define output-file (build-path destination-directory "tools.scm")) 53 | (define repository scheme-env-repository) 54 | (define (download m) 55 | (let-values (((s h b) 56 | (http-get (m 2) (string-append (m 3) "/lib/tools.scm") 57 | :secure (string=? (m 1) "https")))) 58 | (unless (string=? s "200") 59 | (assertion-violation 'scheme-env "tools library not found")) 60 | (call-with-output-file output-file 61 | (lambda (out) (put-string out b))) 62 | output-file)) 63 | (define (retrieve-file) 64 | (cond ((#/(https?):\/\/([^\/]+)(.+)/ repository) => 65 | (lambda (m) 66 | (cond ((file-exists? output-file) output-file) 67 | (else (download m))))) 68 | (else 69 | (let ((repository-file (build-path* repository "lib" "tools.scm"))) 70 | (cond ((file-exists? repository-file) 71 | (copy-file repository-file output-file #t) 72 | output-file) 73 | ((file-exists? repository-file) repository-file) 74 | (else 75 | (assertion-violation 'load-tools-library 76 | "Tools library file not found in specified repository" 77 | ))))))) 78 | (unless (file-exists? destination-directory) 79 | (create-directory* destination-directory)) 80 | (let ((tools (retrieve-file))) 81 | (load tools))) 82 | 83 | (define (load-file command) 84 | (define env (environment '(only (sagittarius) import library define-library))) 85 | (load-tools-library) 86 | (let ((command-not-found? (eval 'scheme-env-command-not-found? 87 | (environment '(tools))))) 88 | (define tools-env (environment '(rnrs) '(tools))) 89 | (guard (e ((command-not-found? e) 90 | (print "No such command: " command) 91 | (exit -1)) 92 | (else (raise e))) 93 | ;; ok we need to specify the library 94 | (let ((file (eval `(scheme-env:script-file ',command) tools-env))) 95 | (load file env) 96 | env)))) 97 | 98 | (define (invoke-command command args) 99 | (let ((env (load-file command))) 100 | (eval `(main ',args) env))) 101 | 102 | (define (usage maybe-command) 103 | (if (null? maybe-command) 104 | (print "scheme-env command [OPTIONS]") 105 | (let ((env (load-file (car maybe-command)))) 106 | ;; May work if I wasn't lazy 107 | (eval '(usage) env))) 108 | (exit -1)) 109 | 110 | (define (main args) 111 | (when (null? (cdr args)) (usage '())) 112 | (case (string->symbol (cadr args)) 113 | ((help) (usage (cddr args))) 114 | (else => (lambda (command) (invoke-command command (cddr args)))))) 115 | -------------------------------------------------------------------------------- /lib/tools.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; tools.scm - Scheme environment tools 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!read-macro=sagittarius/regex 32 | #!nounbound 33 | (library (tools) 34 | (export scheme-env-repository 35 | scheme-env-home 36 | scheme-env-bin-directory 37 | scheme-env-sitelib-directory 38 | scheme-env-metainf-directory 39 | scheme-env-work-directory 40 | scheme-env-implentations-directory 41 | scheme-env-tmp-directory 42 | scheme-env-default-implementation 43 | scheme-env-host-implementation 44 | 45 | scheme-env:call-with-input-uri 46 | 47 | scheme-env:download 48 | scheme-env:script-file 49 | 50 | scheme-env:parse-version 51 | 52 | scheme-env:with-work-directory 53 | 54 | scheme-env:call-with-ftp-connection 55 | 56 | scheme-env:latest-version-from-ftp 57 | scheme-env:download-ftp-archive 58 | scheme-env:semantic-version-compare 59 | scheme-env:semantic-version? 61 | 62 | scheme-env:download-archive 63 | scheme-env:download-github-archive 64 | scheme-env:github-latest-version 65 | scheme-env:extract-archive-port 66 | scheme-env:find-extracted-directory 67 | scheme-env:installation-path 68 | scheme-env:binary-path 69 | scheme-env:create-script-file scheme-env:create-script-file/env 70 | scheme-env:call-with-script-file 71 | scheme-env:finish-message 72 | scheme-env:message 73 | scheme-env:print 74 | 75 | ;; conditions 76 | scheme-env-error 77 | scheme-env-condition? 78 | 79 | scheme-env-command-not-found? 80 | scheme-env-condition-command 81 | 82 | scheme-env-download-condition? 83 | scheme-env-condition-host 84 | scheme-env-condition-path 85 | 86 | scheme-env-github-condition? 87 | ) 88 | (import (rnrs) 89 | (sagittarius) 90 | (sagittarius regex) 91 | (archive) 92 | (util file) 93 | (rfc ftp) 94 | (rfc http) 95 | (rfc gzip) 96 | (rfc uri) 97 | (srfi :1) 98 | (srfi :26) 99 | (srfi :39)) 100 | (define-constant +default-github-repository+ 101 | "https://raw.githubusercontent.com/ktakashi/scheme-env/master") 102 | 103 | (define-condition-type &scheme-env-condition &condition 104 | make-scheme-env-condition scheme-env-condition?) 105 | 106 | (define-condition-type &scheme-env-command-not-found &scheme-env-condition 107 | make-scheme-env-command-not-found scheme-env-command-not-found? 108 | (command scheme-env-condition-command)) 109 | 110 | (define-condition-type &scheme-env-file-not-found &scheme-env-condition 111 | make-scheme-env-file-not-found scheme-env-file-not-found? 112 | (file scheme-env-condition-file)) 113 | 114 | (define-condition-type &scheme-env-download-condition &scheme-env-condition 115 | make-scheme-env-download-condition scheme-env-download-condition? 116 | (host scheme-env-condition-host) 117 | (path scheme-env-condition-path)) 118 | 119 | (define-condition-type &scheme-env-github-condition &scheme-env-condition 120 | make-scheme-env-github-condition scheme-env-github-condition?) 121 | 122 | (define (scheme-env-error who message . irr) 123 | (raise (condition 124 | (make-error) 125 | (make-who-condition who) 126 | (make-scheme-env-condition) 127 | (make-message-condition message) 128 | (make-irritants-condition irr)))) 129 | 130 | (define (scheme-env-download-error host path message) 131 | (raise (condition 132 | (make-error) 133 | (make-who-condition 'scheme-env) 134 | (make-scheme-env-download-condition host path) 135 | (make-message-condition message)))) 136 | 137 | (define (scheme-env-github-error message) 138 | (raise (condition 139 | (make-error) 140 | (make-who-condition 'scheme-env) 141 | (make-scheme-env-github-condition) 142 | (make-message-condition message)))) 143 | 144 | (define (scheme-env-command-not-found-error command message) 145 | (raise (condition 146 | (make-error) 147 | (make-who-condition 'scheme-env) 148 | (make-scheme-env-command-not-found command) 149 | (make-message-condition message)))) 150 | (define (scheme-env-file-not-found-error file message) 151 | (raise (condition 152 | (make-error) 153 | (make-who-condition 'scheme-env) 154 | (make-scheme-env-file-not-found file) 155 | (make-message-condition message)))) 156 | 157 | (define (scheme-env-home) 158 | (or (getenv "SCHEME_ENV_HOME") 159 | (scheme-env-error 'scheme-env-home "SCHEME_ENV_HOME is not set"))) 160 | (define (scheme-env-repository) 161 | (cond ((getenv "SCHEME_ENV_REPOSITORY")) 162 | (else +default-github-repository+))) 163 | (define (scheme-env-bin-directory) (build-path (scheme-env-home) "bin")) 164 | (define (scheme-env-sitelib-directory) (build-path (scheme-env-home) "sitelib")) 165 | (define (scheme-env-metainf-directory) (build-path (scheme-env-home) "metainf")) 166 | (define (scheme-env-work-directory) (build-path (scheme-env-home) "work")) 167 | (define (scheme-env-tmp-directory) (build-path (scheme-env-home) "tmp")) 168 | (define (scheme-env-implentations-directory) 169 | (build-path (scheme-env-home) "implementations")) 170 | (define (scheme-env-default-implementation) 171 | (build-path* (scheme-env-home) "bin" "default")) 172 | (define (scheme-env-host-implementation) 173 | (build-path* (scheme-env-home) "bin" "host-scheme")) 174 | 175 | (define (scheme-env:call-with-input-uri uri proc) 176 | (define (http->binary-port specific secure?) 177 | (define (->server host port) 178 | (if port 179 | (string-append host ":" port) 180 | host)) 181 | (define (->path path query) 182 | (if query 183 | (string-append path "?" query) 184 | path)) 185 | (define receiver (http-gzip-receiver (http-binary-receiver))) 186 | (let*-values (((auth path query frag) (uri-decompose-hierarchical specific)) 187 | ((ui host port) (uri-decompose-authority auth)) 188 | ((s h b) 189 | (http-request 'GET (->server host port) (->path path query) 190 | :secure secure? 191 | :receiver receiver))) 192 | (unless (eqv? (string-ref s 0) #\2) 193 | (assertion-violation 'scheme-env:call-with-input-uri 194 | "HTTP status is not 2xx" uri)) 195 | (open-bytevector-input-port b))) 196 | (let-values (((scheme specific) (uri-scheme&specific uri))) 197 | (cond ((not scheme) (call-with-input-file uri proc :transcoder #f)) 198 | ((string=? scheme "http") (proc (http->binary-port specific #f))) 199 | ((string=? scheme "https") (proc (http->binary-port specific #t))) 200 | (else (assertion-violation 'scheme-env:call-with-input-uri 201 | "Unsupported scheme" scheme))))) 202 | 203 | 204 | (define (scheme-env:download file) 205 | (define destination-directory (scheme-env-home)) 206 | (define output-file (build-path destination-directory file)) 207 | (define repository (scheme-env-repository)) 208 | (define (download m) 209 | (let-values (((s h b) 210 | (http-get (m 2) (string-append (m 3) "/" file) 211 | :secure (string=? (m 1) "https")))) 212 | (unless (string=? s "200") 213 | (scheme-env-file-not-found-error file "file not found")) 214 | (call-with-output-file output-file 215 | (lambda (out) (put-string out b))) 216 | output-file)) 217 | (let-values (((base name ext) (decompose-path output-file))) 218 | (unless (file-exists? base) (create-directory* base))) 219 | (cond ((#/(https?):\/\/([^\/]+)(.+)/ repository) => 220 | (lambda (m) 221 | (cond ((file-exists? output-file) output-file) 222 | (else (download m))))) 223 | (else 224 | (let ((repository-file (build-path repository file))) 225 | (cond ((file-exists? repository-file) 226 | (copy-file repository-file output-file #t) 227 | output-file) 228 | ((file-exists? repository-file) repository-file) 229 | (else 230 | (scheme-env-file-not-found-error file 231 | "File not found in specified repository"))))))) 232 | 233 | (define (->scheme-file pre part) (format "~a/~a.scm" pre part)) 234 | (define (scheme-env:script-file command) 235 | (guard (e (else 236 | (scheme-env-command-not-found-error command "no such command"))) 237 | (scheme-env:download (->scheme-file "scripts" command)))) 238 | 239 | (define (scheme-env:with-work-directory name version proc) 240 | (let ((work-dir (build-path* (scheme-env-work-directory) name version))) 241 | (when (file-exists? work-dir) (delete-directory* work-dir)) 242 | (create-directory* work-dir) 243 | (parameterize ((current-directory work-dir)) (proc work-dir)))) 244 | 245 | (define (scheme-env:call-with-ftp-connection host path proc . args) 246 | (define ftp-conn (apply ftp-login host args)) 247 | (ftp-chdir ftp-conn path) 248 | (guard (e (else (ftp-quit ftp-conn) (raise e))) 249 | (let ((r (proc ftp-conn))) 250 | (ftp-quit ftp-conn) 251 | r))) 252 | 253 | (define (scheme-env:latest-version-from-ftp ftp-conn version-pattern compare) 254 | (define (extract-version name) 255 | (cond ((version-pattern name) => (lambda (m) (m 1))) 256 | (else #f))) 257 | 258 | (let ((r (filter-map extract-version (ftp-name-list ftp-conn)))) 259 | (when (null? r) 260 | (scheme-env-error 'scheme-env:version-from-ftp 261 | "Couldn't determine the latest version from names" 262 | version-pattern)) 263 | (car (list-sort compare r)))) 264 | 265 | (define (scheme-env:download-ftp-archive ftp-conn file) 266 | (ftp-get ftp-conn file)) 267 | 268 | ;; semantic compare 269 | (define (scheme-env:semantic-version-compare v1 v2) 270 | (let loop ((v1* (string-split v1 "\\.")) 271 | (v2* (string-split v2 "\\."))) 272 | (cond ((and (null? v1*) (null? v2*)) 0) 273 | ((null? v1*) -1) 274 | ((null? v2*) 1) 275 | (else 276 | (let ((r (compare (string->number (car v1*)) 277 | (string->number (car v2*))))) 278 | (if (zero? r) 279 | (loop (cdr v1*) (cdr v2*)) 280 | r)))))) 281 | 282 | (define (scheme-env:semantic-version? v1 v2) 285 | (> (scheme-env:semantic-version-compare v1 v2) 0)) 286 | 287 | ;; separated by @ 288 | ;; name@version -> (values name version) 289 | ;; name -> (values name #f) 290 | (define (scheme-env:parse-version arg) 291 | (cond ((#/([^@]+)@(.+)/ arg) => (lambda (m) (values (m 1) (m 2)))) 292 | (else (values arg #f)))) 293 | 294 | (define (scheme-env:download-archive host path 295 | :key (receiver (http-binary-receiver)) :allow-other-keys opt) 296 | (let-values (((s h b) (apply http-get host path :receiver receiver opt))) 297 | (unless (string=? s "200") 298 | (scheme-env-download-error host path "Failed to download")) 299 | b)) 300 | 301 | (define (scheme-env:download-github-archive path . opt) 302 | (apply scheme-env:download-archive "github.com" path :secure #t opt)) 303 | 304 | (define (scheme-env:github-latest-version path) 305 | (define (err msg) (scheme-env-github-error msg)) 306 | (define (parse-version url) 307 | (cond ((#/tag\/(.+?)$/ url) => (lambda (m) (m 1))) 308 | (else (err "Redirecting URL doesn't contain valid path")))) 309 | 310 | (let-values (((s h c) 311 | (http-head "github.com" (format "~a/releases/latest" path) 312 | :secure #t :no-redirect #t))) 313 | (if (string=? s "302") 314 | (cond ((assoc "location" h) => 315 | (lambda (slot) (parse-version (cadr slot)))) 316 | (else (err "No Location header"))) 317 | (err "Invalid Http status code")))) 318 | 319 | (define (scheme-env:extract-archive-port port type) 320 | (define (destinator e) 321 | (let ((name (archive-entry-name e))) 322 | (format #t "-- Extracting: ~a~%" name) 323 | name)) 324 | (let-values (((p t) (case type 325 | ((zip) (values port type)) 326 | ((tar.gz) (values (open-gzip-input-port port) 'tar))))) 327 | (call-with-archive-input t p 328 | (cut extract-all-entries <> :overwrite #t :destinator destinator)))) 329 | 330 | ;; returns first found directory. (should be fine) 331 | (define (scheme-env:find-extracted-directory path) 332 | (call/cc (lambda (return) 333 | (path-for-each path (lambda (p t) 334 | (and (eq? t 'directory) (return p))) 335 | :recursive #f)))) 336 | 337 | (define (scheme-env:installation-path name version) 338 | (build-path* (scheme-env-implentations-directory) name version)) 339 | 340 | (define (scheme-env:binary-path name version) 341 | (build-path* (scheme-env-home) "bin" (format "~a@~a" name version))) 342 | 343 | (define *ld-library-path-name* 344 | (cond-expand 345 | (darwin "DYLD_LIBRARY_PATH") 346 | (else "LD_LIBRARY_PATH"))) 347 | 348 | (define (scheme-env:create-script-file binary-path prefix name bin lib) 349 | (scheme-env:call-with-script-file binary-path prefix name 350 | (lambda (out) 351 | (let ((bin (build-path* prefix bin name)) 352 | (lib (build-path* prefix lib))) 353 | (format out "exec env ~a=~a:${~a} ~a \"$@\"~%" 354 | *ld-library-path-name* lib *ld-library-path-name* bin))))) 355 | 356 | (define (scheme-env:create-script-file/env binary-path prefix name bin lib env) 357 | (scheme-env:call-with-script-file binary-path prefix name 358 | (lambda (out) 359 | (let ((bin (build-path* prefix bin name)) 360 | (lib (build-path* prefix lib))) 361 | (format out "exec env ~a=~a:${~a} ~a ~a \"$@\"~%" 362 | *ld-library-path-name* lib *ld-library-path-name* env bin))))) 363 | 364 | (define (scheme-env:call-with-script-file binary-path prefix name proc) 365 | (define (call-with-safe-output-file file proc) 366 | (when (file-exists? file) (delete-file file)) 367 | (call-with-output-file file proc)) 368 | (let ((new binary-path) 369 | (script (build-path* prefix name))) 370 | (when (file-exists? script) (delete-file script)) 371 | (call-with-output-file script 372 | (lambda (out) 373 | (put-string out "#!/bin/sh\n") 374 | (proc out) 375 | (change-file-mode script #o775) 376 | (when (file-exists? new) (delete-file new)) 377 | (create-symbolic-link script new) 378 | script)))) 379 | 380 | (define (scheme-env:finish-message implementation version) 381 | (format #t "~a@~a is installed ~%" implementation version)) 382 | 383 | (define (scheme-env:message message) 384 | (display message) 385 | (flush-output-port (current-output-port))) 386 | (define (scheme-env:print . args) (for-each display args) (newline)) 387 | ) 388 | -------------------------------------------------------------------------------- /scripts/command-line.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; command-line.scm - Scheme environment command-line command script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | (import (rnrs) 32 | (rnrs eval) 33 | (sagittarius) 34 | (scheme load) 35 | (getopt) 36 | (srfi :13) 37 | (tools)) 38 | 39 | (define (print . args) (for-each display args) (newline)) 40 | 41 | ;; It seems -I is pretty much common to add load path. 42 | (define (common-converter flags) 43 | (define (add-script script includes) 44 | (if script 45 | (string-append includes " " script) 46 | includes)) 47 | ;; we ignore the standard flags 48 | (let ((includes (car flags)) 49 | (script (cadr flags))) 50 | (add-script script 51 | (string-join (map (lambda (p) (string-append "-I" p)) 52 | includes))))) 53 | 54 | (define (invoke-converter impl flags) 55 | (guard (e (else (common-converter flags))) 56 | (let-values (((impl version) (scheme-env:parse-version impl))) 57 | (let ((file (scheme-env:script-file (format "command-line/~a" impl))) 58 | (env (environment '(only (sagittarius) 59 | import library define-library)))) 60 | (load file env) 61 | (eval `(convert ,impl ,version ',flags) env))))) 62 | 63 | (define (adjust-argument impl passing) 64 | (guard (e (else passing)) 65 | (let-values (((impl version) (scheme-env:parse-version impl))) 66 | (let ((file (scheme-env:script-file 67 | (format "command-line/adjust/~a" impl))) 68 | (env (environment '(only (sagittarius) 69 | import library define-library)))) 70 | (load file env) 71 | (eval `(adjust ,impl ,version ',passing) env))))) 72 | 73 | ;; for some reason this is not in any library... 74 | (define (split-when pred lis) 75 | (let loop ((lis lis) (r '())) 76 | (cond ((null? lis) (values (reverse! r) lis)) 77 | ((pred (car lis)) (values (reverse! r) lis)) 78 | (else (loop (cdr lis) (cons (car lis) r)))))) 79 | 80 | ;; after -- is for just passing 81 | (define (parse-command-line args) 82 | (define (check-standard standard) 83 | (and standard 84 | (case (string->symbol standard) 85 | ((r6rs) 'r6rs) 86 | ((r7rs) 'r7rs) 87 | (else (assertion-violation 88 | 'command-line "only R6RS or R7RS is supported" standard))))) 89 | (let-values (((flags rest) (split-when (lambda (v) (equal? "--" v)) args))) 90 | (with-args flags 91 | ((includes (#\l "loadpath") * '()) 92 | (program (#\p "program") #t #f) 93 | (standard (#\r "standard") #t #f) 94 | . maybe-file) 95 | (when (and program (not (null? maybe-file))) 96 | (assertion-violation 'command-line "--program and loading file can't be specified simultaneously")) 97 | (let ((file (if (null? maybe-file) #f (car maybe-file)))) 98 | (values `(,includes ,(or program file) ,(check-standard standard)) 99 | (if (null? rest) rest (cdr rest))))))) 100 | 101 | ;; for invocation from run.scm 102 | (define (convert-command-line args) 103 | (let ((impl (car args))) 104 | (let*-values (((flags passing) (parse-command-line (cdr args)))) 105 | (let ((converted (if (null? flags) "" (invoke-converter impl flags))) 106 | (passing (if (null? passing) '() (adjust-argument impl passing)))) 107 | (values converted passing))))) 108 | 109 | 110 | (define (main args) 111 | (when (null? args) (usage)) 112 | (let-values (((converted passing) (convert-command-line args))) 113 | (if (null? passing) 114 | (print converted) 115 | (print converted " " (string-join passing))))) 116 | -------------------------------------------------------------------------------- /scripts/command-line/chez.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; command-line/sagittarius.scm - Sagittarius command-line command script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!nounbound 32 | (import (rnrs) 33 | (sagittarius) 34 | (srfi :13) 35 | (tools)) 36 | 37 | (define (convert name version flags) 38 | (define (add-script script standard command) 39 | (if script 40 | (string-append command 41 | (if (eq? standard 'r6rs) " --program " " --script ") 42 | script) 43 | command)) 44 | (let ((includes (car flags))) 45 | (add-script (cadr flags) (caddr flags) 46 | (if (null? includes) 47 | "" 48 | (string-append "--libdirs " (string-join includes ":")))))) 49 | -------------------------------------------------------------------------------- /scripts/command-line/gauche.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; command-line/gauche.scm - Gauche command-line command script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!nounbound 32 | (import (rnrs) 33 | (sagittarius) 34 | (srfi :13) 35 | (tools)) 36 | 37 | (define (convert name version flags) 38 | (define (add-script script command) 39 | (if script 40 | (string-append command " " script) 41 | command)) 42 | (define (add-standard standard command) 43 | (string-append command (case standard 44 | ((r7rs) " -r7") 45 | (else "")))) 46 | (let ((includes (car flags))) 47 | (add-script (cadr flags) 48 | (add-standard (caddr flags) 49 | (string-join (map (lambda (p) (string-append "-I" p)) includes)))))) 50 | -------------------------------------------------------------------------------- /scripts/command-line/larceny.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; command-line/larceny.scm - Larceny command-line command script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!nounbound 32 | (import (rnrs) 33 | (sagittarius) 34 | (srfi :13) 35 | (tools)) 36 | 37 | (define (convert name version flags) 38 | (define (add-script script command) 39 | (if script 40 | (string-append command " -program " script) 41 | command)) 42 | (define (add-standard standard command) 43 | (string-append command (case standard 44 | ((r6rs) " -r6rs") 45 | ((r7rs) " -r7rs") 46 | (else "")))) 47 | ;; we ignore the standard flags 48 | (let ((includes (car flags))) 49 | (add-script (cadr flags) 50 | (add-standard (caddr flags) 51 | (if (null? includes) 52 | "" 53 | (string-append 54 | (if (> (string->number version) 1) 55 | "-I " 56 | "-path ") 57 | (string-join includes ":"))))))) 58 | -------------------------------------------------------------------------------- /scripts/command-line/sagittarius.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; command-line/sagittarius.scm - Sagittarius command-line command script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!nounbound 32 | (import (rnrs) 33 | (sagittarius) 34 | (srfi :13) 35 | (tools)) 36 | 37 | (define (convert name version flags) 38 | (define (add-script script command) 39 | (if script 40 | (string-append command " " script) 41 | command)) 42 | (define (add-standard standard command) 43 | (string-append command (case standard 44 | ((r6rs) " -r6") 45 | ((r7rs) " -r7") 46 | (else "")))) 47 | (let ((includes (car flags))) 48 | (add-script (cadr flags) 49 | (add-standard (caddr flags) 50 | (string-join (map (lambda (p) (string-append "-L" p)) includes)))))) 51 | -------------------------------------------------------------------------------- /scripts/host-update.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; host-update.scm - Scheme environment host-update command script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | (import (rnrs) 32 | (sagittarius) 33 | (sagittarius process) 34 | (util file) 35 | (tools) 36 | (srfi :13) 37 | (srfi :14) 38 | (srfi :18)) 39 | 40 | (define (usage) 41 | (scheme-env:message "scheme-env host-update path-or-name") 42 | (scheme-env:message " Updates the host Scheme with given path") 43 | (exit -1)) 44 | 45 | (define (resolve-path path) 46 | (cond ((and (file-exists? path) (absolute-path? path)) path) ;; let's check 47 | ((and (string-contains path "@") (string-prefix? "sagittarius" path)) 48 | (let ((link (build-path (scheme-env-bin-directory) path))) 49 | (and (file-exists? link) link))) 50 | (else #f))) 51 | 52 | 53 | (define (update path) 54 | (define real-path (resolve-path path)) 55 | (define (reader process stdout stderr transcoder) 56 | (define (make-task in out) 57 | (define tin (transcoded-port in (native-transcoder))) 58 | (lambda () 59 | (let loop () 60 | (if (port-ready? tin) 61 | (let ((line (get-line tin))) 62 | (put-string out line)) 63 | (begin 64 | (thread-sleep! 0.1) 65 | (loop)))))) 66 | (let ((in (process-output-port process))) 67 | (values process (thread-start! (make-thread (make-task in stdout)))))) 68 | (define (compare-version new old) 69 | (let loop ((new (map string->number new)) (old (map string->number old))) 70 | (cond ((and (null? new) (null? old)) #t) 71 | ((null? new) #f) 72 | ((null? old) #t) ;; 4 digits 73 | ((> (car new) (car old)) #t) 74 | ((= (car new) (car old)) (loop (cdr new) (cdr old))) 75 | (else #f)))) 76 | (unless real-path 77 | (assertion-violation 'host-update "The given path or name doesn't exist" 78 | path)) 79 | (scheme-env:message "Checking version ... ") 80 | (let*-values (((out extract) (open-string-output-port)) 81 | ((p thread) 82 | (create-process real-path 83 | '("-e" "(print (sagittarius-version)) (exit)") 84 | :stdout out 85 | :reader reader))) 86 | (thread-join! thread) 87 | (scheme-env:print "done!") 88 | (let* ((version (extract)) 89 | (new-version (string-tokenize version char-set:digit)) 90 | (old-version (string-tokenize (sagittarius-version) char-set:digit))) 91 | (scheme-env:print (format "New version ... ~a" version)) 92 | ;; must be newer version 93 | (if (compare-version new-version old-version) 94 | (let ((host (scheme-env-host-implementation))) 95 | (when (file-exists? host) (delete-file host)) 96 | (create-symbolic-link real-path host) 97 | (scheme-env:print "Host Scheme is updated")) 98 | (scheme-env:print "Specified Sagittarius older than current"))))) 99 | 100 | (define (main args) 101 | (when (null? args) (usage)) 102 | (update (car args))) 103 | -------------------------------------------------------------------------------- /scripts/install.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; install.scm - Scheme environment install command script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!read-macro=sagittarius/regex 32 | (import (rnrs) 33 | (rnrs eval) 34 | (sagittarius) 35 | (sagittarius regex) 36 | (scheme load) 37 | (tools)) 38 | 39 | (define (invoke-installer implementation version) 40 | (let ((file (scheme-env:script-file (format "install/~a" implementation))) 41 | (env (environment '(only (sagittarius) import library define-library)))) 42 | (load file env) 43 | (eval `(install ,version) env))) 44 | 45 | (define (usage) 46 | (define p scheme-env:print) 47 | (p "scheme-env install ...") 48 | (p) 49 | (p "Description") 50 | (p " Installs specified s.") 51 | (p) 52 | (p " format") 53 | (p " - implementation") 54 | (p " - implementation@version") 55 | (p) 56 | (p " Supporting implementations") 57 | (p " - chez") 58 | (p " - chibi-scheme") 59 | (p " - foment") 60 | (p " - gauche") 61 | (p " - larceny") 62 | (p " - sagittarius") 63 | (exit -1)) 64 | 65 | (define (main args) 66 | (when (null? args) (usage)) 67 | (for-each (lambda (implementation) 68 | (let-values (((impl version) 69 | (scheme-env:parse-version implementation))) 70 | (invoke-installer impl version))) 71 | args)) 72 | -------------------------------------------------------------------------------- /scripts/install/chez.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; install/chez.scm - Chez Scheme install script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!nounbound 32 | (import (rnrs) 33 | (sagittarius) 34 | (sagittarius process) 35 | (tools) 36 | (srfi :39)) 37 | 38 | (define (install version) 39 | (define real-version 40 | (or version (scheme-env:github-latest-version "/cisco/ChezScheme"))) 41 | (define install-prefix 42 | (scheme-env:installation-path "chez" real-version)) 43 | (define (download) 44 | (let ((b (scheme-env:download-github-archive 45 | (format "/cisco/ChezScheme/releases/download/~a/cs~a.tar.gz" 46 | real-version real-version)))) 47 | (scheme-env:extract-archive-port (open-bytevector-input-port b) 'tar.gz))) 48 | (scheme-env:with-work-directory "chez" real-version 49 | (lambda (work-dir) 50 | (download) 51 | (let ((path (scheme-env:find-extracted-directory "."))) 52 | (parameterize ((current-directory path)) 53 | (run "sh" "configure" 54 | "--threads" 55 | (format "--installprefix=~a" install-prefix)) 56 | (run "make") 57 | (run "make" "install"))))) 58 | (let ((new (scheme-env:binary-path "chez" real-version))) 59 | (scheme-env:call-with-script-file new install-prefix "chez" 60 | (lambda (out) (format out "~a/bin/scheme \"$@\"~%" install-prefix))) 61 | (scheme-env:finish-message "Chez Scheme" real-version))) 62 | -------------------------------------------------------------------------------- /scripts/install/chibi-scheme.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; install/chibi-scheme.scm - Chibi Scheme install script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!nounbound 32 | (import (rnrs) 33 | (sagittarius) 34 | (sagittarius process) 35 | (tools) 36 | (srfi :39)) 37 | 38 | (define (install version) 39 | (define real-version (or version "master")) 40 | (define install-prefix 41 | (scheme-env:installation-path "chibi-scheme" real-version)) 42 | (define (download) 43 | (let ((b (scheme-env:download-github-archive 44 | (format "/ashinn/chibi-scheme/archive/~a.zip" real-version)))) 45 | (scheme-env:extract-archive-port (open-bytevector-input-port b) 'zip))) 46 | (scheme-env:with-work-directory "chibi-scheme" real-version 47 | (lambda (work-dir) 48 | (download) 49 | (let ((path (scheme-env:find-extracted-directory ".")) 50 | (prefix (format "PREFIX=~a" install-prefix))) 51 | (parameterize ((current-directory path)) 52 | (run "make" prefix) 53 | (run "make" prefix "install"))))) 54 | (let ((new (scheme-env:binary-path "chibi-scheme" real-version))) 55 | (scheme-env:create-script-file new install-prefix 56 | "chibi-scheme" "bin" "lib") 57 | (scheme-env:finish-message "Chibi Scheme" real-version))) 58 | -------------------------------------------------------------------------------- /scripts/install/chicken-scheme.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; install/chibi-scheme.scm - Chibi Scheme install script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!nounbound 32 | (import (rnrs) 33 | (sagittarius) 34 | (sagittarius process) 35 | (tools) 36 | (rfc http) 37 | (srfi :13) 38 | (srfi :39)) 39 | 40 | (define-constant +call-cc.org+ "code.call-cc.org") 41 | (define (get-current-version) 42 | (let-values (((s h b) (http-get +call-cc.org+ "/releases/current/NEWS"))) 43 | (string-trim-both (get-line (open-string-input-port b))))) 44 | 45 | (define (install version) 46 | (define real-version (or version (get-current-version))) 47 | (define install-prefix 48 | (scheme-env:installation-path "chicken-scheme" real-version)) 49 | (define (download) 50 | (let ((b (scheme-env:download-archive +call-cc.org+ 51 | (format "/releases/~a/chicken.tar.gz" real-version)))) 52 | (scheme-env:extract-archive-port (open-bytevector-input-port b) 'tar.gz))) 53 | (scheme-env:with-work-directory "chicken-scheme" real-version 54 | (lambda (work-dir) 55 | (download) 56 | (let ((path (scheme-env:find-extracted-directory ".")) 57 | (prefix (format "PREFIX=~a" install-prefix)) 58 | (platform (format "PLATFORM=~a" 59 | (cond-expand (darwin "macosx") (else "linux"))))) 60 | (parameterize ((current-directory path)) 61 | (run "make" prefix platform) 62 | (run "make" prefix platform "install"))))) 63 | (let ((new (scheme-env:binary-path "chicken-scheme" real-version)) 64 | (csi (scheme-env:binary-path "csi" real-version)) 65 | (csc (scheme-env:binary-path "csc" real-version))) 66 | (scheme-env:create-script-file new install-prefix "chicken" "bin" "lib") 67 | (scheme-env:create-script-file csi install-prefix "csi" "bin" "lib") 68 | (scheme-env:create-script-file csc install-prefix "csc" "bin" "lib") 69 | (scheme-env:finish-message "Chicken Scheme" real-version))) 70 | -------------------------------------------------------------------------------- /scripts/install/foment.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; install/foment.scm - Foment install script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!nounbound 32 | (import (rnrs) 33 | (sagittarius) 34 | (sagittarius process) 35 | (tools) 36 | (util file) 37 | (srfi :39)) 38 | 39 | (define (install version) 40 | (define real-version (or version "master")) 41 | (define (download) 42 | (let ((b (scheme-env:download-github-archive 43 | (format "/leftmike/foment/archive/~a.zip" real-version)))) 44 | (scheme-env:extract-archive-port (open-bytevector-input-port b) 'zip))) 45 | (define install-dir (scheme-env:installation-path "foment" real-version)) 46 | (scheme-env:with-work-directory "foment" real-version 47 | (lambda (work-dir) 48 | (let () 49 | (download) 50 | (let ((path (scheme-env:find-extracted-directory "."))) 51 | (parameterize ((current-directory (build-path path "unix"))) 52 | (run "make") 53 | (unless (file-exists? install-dir) 54 | (create-directory* install-dir)) 55 | (copy-file "release/foment" 56 | (build-path install-dir "foment"))))))) 57 | (let ((new (scheme-env:binary-path "foment" real-version)) 58 | (old (build-path* install-dir "foment"))) 59 | (when (file-exists? new) (delete-file new)) 60 | (create-symbolic-link old new) 61 | (scheme-env:finish-message "Foment" real-version))) 62 | -------------------------------------------------------------------------------- /scripts/install/gauche.scm: -------------------------------------------------------------------------------- 1 | #!nounbound 2 | (import (rnrs) 3 | (sagittarius) 4 | (sagittarius process) 5 | (rfc http) 6 | (util file) 7 | (tools) 8 | (srfi :39)) 9 | 10 | ;; designator can be #f, "latest" or "snapshot" 11 | (define (get-real-version designator) 12 | (let-values (((s h b) 13 | (http-get "practical-scheme.net" 14 | (format "/gauche/releases/~a.txt" 15 | (or designator "latest")) 16 | :secure #t))) 17 | (unless (string=? s "200") 18 | (assertion-violation 'gauche "Failed to get latest version of Gauche" s h)) 19 | b)) 20 | 21 | (define (get-get-gauche filename) 22 | (let-values (((s h b) 23 | (http-get "raw.githubusercontent.com" 24 | "/shirok/get-gauche/master/get-gauche.sh" 25 | :receiver (http-file-receiver filename :temporary? #t) 26 | :secure #t))) 27 | (unless (string=? s "200") 28 | (assertion-violation 'gauche "Failed to get get-gauche" s h)) 29 | (change-file-mode b #o775) 30 | b)) 31 | 32 | (define (install version) 33 | (define real-version 34 | (if (member version '(#f "latest" "snapshot")) 35 | (get-real-version version) 36 | version)) 37 | (define install-prefix (scheme-env:installation-path "gauche" real-version)) 38 | (scheme-env:with-work-directory "gauche" real-version 39 | (lambda (work-dir) 40 | (let ((get-gauche.sh (get-get-gauche 41 | (build-path* work-dir "get-gauche.sh")))) 42 | (run get-gauche.sh 43 | "--prefix" install-prefix 44 | "--version" real-version 45 | "--force" "--auto")))) 46 | (let ((new (scheme-env:binary-path "gauche" real-version))) 47 | (scheme-env:create-script-file new install-prefix "gosh" "bin" "lib")) 48 | (scheme-env:finish-message "Gauche" real-version)) 49 | 50 | 51 | -------------------------------------------------------------------------------- /scripts/install/guile.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; install/guile.scm - Guile Scheme install script 4 | ;;; 5 | ;;; Copyright (c) 2022 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!nounbound 32 | #!read-macro=sagittarius/regex 33 | (import (rnrs) 34 | (sagittarius) 35 | (sagittarius process) 36 | (sagittarius regex) 37 | (tools) 38 | (srfi :39)) 39 | 40 | (define (install version) 41 | (define real-version 42 | (scheme-env:call-with-ftp-connection "ftp.gnu.org" "/gnu/guile/" 43 | (lambda (ftp-conn) 44 | (or version (scheme-env:latest-version-from-ftp 45 | ftp-conn #/guile-(\d\.\d\.\d).tar.gz/ 46 | scheme-env:semantic-version>?))))) 47 | (define install-prefix 48 | (scheme-env:installation-path "guile" real-version)) 49 | (define (download) 50 | (define file (format "/gnu/guile/guile-~a.tar.gz" real-version)) 51 | (scheme-env:print "Downloading " file) 52 | (let ((b (scheme-env:download-archive "ftp.gnu.org" file 53 | :secure #t))) 54 | (scheme-env:extract-archive-port (open-bytevector-input-port b) 'tar.gz))) 55 | (scheme-env:with-work-directory "guile" real-version 56 | (lambda (work-dir) 57 | (download) 58 | (let ((path (scheme-env:find-extracted-directory "."))) 59 | (parameterize ((current-directory path)) 60 | (run "sh" "configure" (format "--prefix=~a" install-prefix)) 61 | (run "make") 62 | (run "make" "install"))))) 63 | (let ((new (scheme-env:binary-path "guile" real-version))) 64 | (scheme-env:call-with-script-file new install-prefix "guile" 65 | (lambda (out) (format out "~a/bin/guile \"$@\"~%" install-prefix))) 66 | (scheme-env:finish-message "Guile Scheme" real-version))) 67 | -------------------------------------------------------------------------------- /scripts/install/larceny.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; install/larceny - Larceny install script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!nounbound 32 | (import (rnrs) 33 | (sagittarius) 34 | (sagittarius process) 35 | (rfc http) 36 | (util file) 37 | (tools) 38 | (srfi :13) 39 | (srfi :39)) 40 | 41 | (define-constant +larcenists+ "www.larcenists.org") 42 | (define (ask-version) 43 | (display "Please entire the version (e.g. 1.3)") (newline) 44 | (display "> ") (flush-output-port) 45 | (get-line (current-input-port))) 46 | 47 | (define (install version) 48 | (define real-version (or version (ask-version))) 49 | (define install-prefix 50 | (scheme-env:installation-path "larceny" real-version)) 51 | (define (download platform) 52 | (let ((b (scheme-env:download-archive +larcenists+ 53 | (format "/LarcenyReleases/larceny-~a-bin-native-ia32-~a.tar.gz" 54 | real-version platform)))) 55 | (scheme-env:extract-archive-port (open-bytevector-input-port b) 'tar.gz))) 56 | (scheme-env:with-work-directory "larceny" real-version 57 | (lambda (work-dir) 58 | (download (cond-expand (darwin "macosx") (else "linux86"))) 59 | (let ((path (scheme-env:find-extracted-directory ".")) 60 | (implementation-path 61 | (build-path (scheme-env-implentations-directory) "larceny"))) 62 | (when (file-exists? install-prefix) (delete-directory* install-prefix)) 63 | (unless (file-exists? implementation-path) 64 | (create-directory* implementation-path)) 65 | (rename-file path install-prefix)))) 66 | (let ((new (scheme-env:binary-path "larceny" real-version))) 67 | (scheme-env:call-with-script-file new install-prefix "run-larceny" 68 | (lambda (out) 69 | (format out "exec env LARCENY_ROOT=~a sh ~a/larceny \"$@\"~%" 70 | install-prefix 71 | install-prefix))) 72 | (scheme-env:finish-message "Larceny" real-version))) 73 | 74 | -------------------------------------------------------------------------------- /scripts/install/sagittarius.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; install/sagittarius.scm - Sagittarius Scheme install script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!nounbound 32 | (import (rnrs) 33 | (sagittarius) 34 | (sagittarius process) 35 | (rfc http) 36 | (util file) 37 | (tools) 38 | (srfi :13) 39 | (srfi :39)) 40 | 41 | (define-constant +butbucket+ "bitbucket.org") 42 | (define (get-latest-version) 43 | (define version.txt 44 | "/ktakashi/sagittarius-scheme/downloads/latest-version.txt") 45 | (let-values (((s h b) (http-get +butbucket+ version.txt :secure #t))) 46 | (string-trim-both b))) 47 | 48 | (define (install version) 49 | (define real-version (or version (get-latest-version))) 50 | (define install-prefix 51 | (build-path* (scheme-env-implentations-directory) 52 | "sagittarius" real-version)) 53 | (define (download-head) 54 | (let ((b (scheme-env:download-github-archive 55 | "/ktakashi/sagittarius-scheme/archive/master.zip"))) 56 | (scheme-env:extract-archive-port (open-bytevector-input-port b) 'zip))) 57 | (define (download-version version) 58 | (define path 59 | (format "/ktakashi/sagittarius-scheme/downloads/sagittarius-~a.tar.gz" 60 | version)) 61 | (define file "sagittarius.tar.gz") 62 | (let-values (((s h b) 63 | (http-get +butbucket+ path 64 | :receiver (http-file-receiver file) 65 | :secure #t))) 66 | (unless (string=? s "200") 67 | (assertion-violation 'sagittarius 68 | "Failed to download Sagittarius Scheme" s h)) 69 | (call-with-input-file file 70 | (lambda (in) (scheme-env:extract-archive-port in 'tar.gz)) 71 | :transcoder #f))) 72 | (define (download) 73 | (cond ((equal? real-version "head") (download-head)) 74 | (else (download-version real-version)))) 75 | (define (run-dist) 76 | (when (equal? real-version "head") 77 | (run "env" (format "SASH=~a/bin/host-scheme" (scheme-env-home)) 78 | "sh" "dist.sh" "gen"))) 79 | (define (cache-env) 80 | (format "SAGITTARIUS_CACHE_DIR=~a" (scheme-env-tmp-directory))) 81 | (scheme-env:with-work-directory "sagittarius" real-version 82 | (lambda (work-dir) 83 | (download) 84 | (let ((path (scheme-env:find-extracted-directory ".")) 85 | (prefix (format "-DCMAKE_INSTALL_PREFIX=~a" install-prefix))) 86 | (parameterize ((current-directory path)) 87 | (run-dist) 88 | (run "cmake" prefix ".") 89 | (run "make") 90 | (run "make" "install"))))) 91 | (let ((new (scheme-env:binary-path "sagittarius" real-version))) 92 | (scheme-env:create-script-file/env 93 | new install-prefix "sagittarius" "bin" "lib" (cache-env)) 94 | (scheme-env:finish-message "Sagittarius Scheme" real-version))) 95 | -------------------------------------------------------------------------------- /scripts/invalidate.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; invalidate.scm - Scheme environment invalidate command script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | (import (rnrs) 32 | (util file) 33 | (tools)) 34 | 35 | (define (usage) 36 | (define p scheme-env:print) 37 | (p "scheme-env invalidate") 38 | (p) 39 | (p "Description") 40 | (p " Invalidates the downloaded scripts") 41 | (exit -1)) 42 | 43 | (define (invalidate) 44 | (scheme-env:message "Invalidating scripts ... ") 45 | (delete-directory* (build-path (scheme-env-home) "scripts")) 46 | (scheme-env:print "done!") 47 | (scheme-env:message "Invalidating lib ... ") 48 | (delete-directory* (build-path (scheme-env-home) "lib")) 49 | (scheme-env:print "done!")) 50 | 51 | (define (main args) 52 | (unless (null? args) (usage)) 53 | (invalidate)) 54 | -------------------------------------------------------------------------------- /scripts/list.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; list.scm - Scheme environment list command script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | (import (rnrs) 32 | (util file) 33 | (tools) 34 | (getopt) 35 | (srfi :13)) 36 | 37 | (define (usage) 38 | (define p scheme-env:print) 39 | (p "scheme-env list [-l]") 40 | (p) 41 | (p "Description") 42 | (p " Lists all the installed implementations") 43 | (p) 44 | (p " -l,--list") 45 | (p " Do not put any excess messaage.") 46 | (exit -1)) 47 | 48 | (define (main args) 49 | (with-args args 50 | ((list? (#\l "list") #f #f) 51 | . ignore) 52 | (unless list? (scheme-env:print "Installed implementations:")) 53 | (path-for-each (scheme-env-bin-directory) 54 | (lambda (path type) 55 | (when (string-contains path "@") 56 | (case (string->symbol path) 57 | ((default host-scheme scheme-env)) 58 | (else 59 | (if list? 60 | (scheme-env:print path) 61 | (scheme-env:print " " path)))))) 62 | :recursive #f 63 | :absolute-path #f))) 64 | 65 | -------------------------------------------------------------------------------- /scripts/remove.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; remove.scm - Scheme environment remove command script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | (import (rnrs) 32 | (sagittarius) 33 | (util file) 34 | (srfi :13) 35 | (tools)) 36 | 37 | (define (usage) 38 | (define p scheme-env:print) 39 | (p "scheme-env remove implementation ...") 40 | (p) 41 | (p "Description") 42 | (p " Removes specified implementations") 43 | (p " To check the installed implementations, please use `list` command") 44 | (exit -1)) 45 | 46 | (define (remove-implementation impl) 47 | (define bin (build-path (scheme-env-bin-directory) impl)) 48 | (define (err msg . irr) 49 | (scheme-env:print msg) 50 | (for-each (lambda (i) (scheme-env:print " irritant: " i)) irr)) 51 | (define (do-remove symlink) 52 | (let-values (((name version) (scheme-env:parse-version impl))) 53 | (delete-directory* (build-path* (scheme-env-implentations-directory) 54 | name version)) 55 | (delete-file symlink) 56 | (scheme-env:print impl " has been removed"))) 57 | (if (and (string-contains impl "@") (file-exists? bin)) 58 | (let ((host-scheme (absolute-path (scheme-env-host-implementation))) 59 | (target (absolute-path bin))) 60 | (if (equal? host-scheme target) 61 | (err "Attempt to remove host scheme" impl) 62 | (do-remove bin))) 63 | (err "Invalid file" bin))) 64 | 65 | (define (main args) 66 | (when (null? args) (usage)) 67 | (for-each remove-implementation args)) 68 | -------------------------------------------------------------------------------- /scripts/run.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding:utf-8; -*- 2 | ;;; 3 | ;;; run.scm - Scheme environment run command script 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | (import (rnrs) 32 | (rnrs eval) 33 | (scheme load) 34 | (only (sagittarius) absolute-path) 35 | (sagittarius ffi) 36 | (util file) 37 | (tools) 38 | (srfi :0) 39 | (srfi :13)) 40 | 41 | (define libc 42 | (open-shared-library 43 | (cond-expand 44 | (cygwin "cygwin1.dll") 45 | (darwin "libSystem.dylib") 46 | (32bit "libc.so") 47 | (else "libc.so.6")))) 48 | 49 | (define exec (c-function libc int execv (void* void*))) 50 | (define default (build-path (scheme-env-bin-directory) "default")) 51 | 52 | (define (get-implementation/default name) 53 | (let ((path (build-path (scheme-env-bin-directory) name))) 54 | (if (file-exists? path) 55 | path 56 | default))) 57 | 58 | (define (->pointer path converted passing) 59 | (if converted 60 | ;; it's rather weird but okay. 61 | (let* ((tokens (string-tokenize converted)) 62 | (args (list->vector (append tokens passing))) 63 | (len (vector-length args))) 64 | (do ((i 0 (+ i 1)) 65 | (array (allocate-pointer (* size-of-void* (+ len 2))))) 66 | ((= i len) 67 | (pointer-set-c-pointer! array 0 path) 68 | array) 69 | (pointer-set-c-pointer! array (* (+ i 1) size-of-void*) 70 | (vector-ref args i)))) 71 | (let ((array (allocate-pointer (* size-of-void* 2)))) 72 | (pointer-set-c-pointer! array 0 path) 73 | array))) 74 | 75 | (define (usage) 76 | (define p scheme-env:print) 77 | (p "scheme-env run [implementation] [options ...]") 78 | (p) 79 | (p "Description") 80 | (p " Executes the [implementation] with the given [options ...].") 81 | (p) 82 | (p " If [implementation] is omit, then the default implementation is used") 83 | (p " and raw [options ...] will be passed") 84 | (p) 85 | (p " If [implementation] is provided, then [options ...] can also be the") 86 | (p " following generic options:") 87 | (p) 88 | (p " -l,--loadpath ") 89 | (p " Adding load path, this option can be specified multiple times") 90 | (p " -p,--program