├── .github └── workflows │ ├── linux.yml │ └── osx.yml ├── .gitignore ├── Makefile ├── README.md ├── bin ├── archive.lisp ├── build.lisp ├── config.lisp ├── download.lisp ├── install-quicklisp.lisp ├── main.lisp ├── roswell-bin.asd ├── uname.lisp └── util.lisp ├── lib ├── clingon.extensions.lisp ├── config.default.lisp ├── config │ ├── main.lisp │ └── roswell2.cmd.config.asd ├── impl │ ├── install │ │ ├── main.lisp │ │ ├── roswell2.impl.install.asd │ │ └── sbcl │ │ │ ├── main.lisp │ │ │ └── roswell2.install.sbcl.asd │ ├── main.lisp │ └── roswell2.cmd.impl.asd ├── install │ ├── main.lisp │ └── roswell2.cmd.install.asd ├── internal │ ├── main.lisp │ └── roswell2.cmd.internal.asd ├── main.lisp ├── roswell-bin.asd ├── roswell.quicklisp.extensions.asd ├── roswell.quicklisp.extensions.lisp ├── roswell2.asd ├── run │ ├── main.lisp │ ├── roswell2.cmd.run.asd │ └── sbcl │ │ ├── init.lisp │ │ ├── main.lisp │ │ └── roswell2.run.sbcl.asd ├── script │ ├── impl │ │ ├── main.lisp │ │ └── roswell2.script.impl.asd │ ├── init │ │ ├── main.lisp │ │ └── roswell2.script.init.asd │ ├── install │ │ ├── main.lisp │ │ └── roswell2.script.install.asd │ ├── main.lisp │ ├── ros-loader.lisp │ ├── roswell2.cmd.script.asd │ ├── run │ │ ├── main.lisp │ │ └── roswell2.script.run.asd │ └── uninstall │ │ ├── main.lisp │ │ └── roswell2.script.uninstall.asd └── version │ ├── main.lisp │ └── roswell2.cmd.version.asd └── patch-2.2.0 /.github/workflows/linux.yml: -------------------------------------------------------------------------------- 1 | name: linux 2 | 3 | on: 4 | push: 5 | workflow_dispatch: 6 | 7 | jobs: 8 | build: 9 | runs-on: ubuntu-latest 10 | strategy: 11 | fail-fast: false 12 | matrix: 13 | target: [arm64, x86-64] 14 | steps: 15 | - uses: actions/checkout@v4 16 | - name: Set up QEMU 17 | uses: docker/setup-qemu-action@v3 18 | with: 19 | image: tonistiigi/binfmt:qemu-v8.1.5 20 | - name: build 21 | env: 22 | DOCKER_PLATFORM: ${{ matrix.target == 'arm64' && 'linux/arm64' || 'linux/amd64' }} 23 | run: | 24 | make linux-build archive 25 | - name: upload artifacts 26 | uses: actions/upload-artifact@v4 27 | with: 28 | name: ${{ matrix.target == 'arm64' && 'roswell-linux-arm64' || 'roswell-linux' }} 29 | path: ./*.tbz 30 | -------------------------------------------------------------------------------- /.github/workflows/osx.yml: -------------------------------------------------------------------------------- 1 | name: osx 2 | 3 | on: 4 | push: 5 | workflow_dispatch: 6 | 7 | jobs: 8 | build: 9 | runs-on: ${{ matrix.target == 'arm64' && 'macos-14' || 'macOS-12' }} 10 | strategy: 11 | fail-fast: false 12 | matrix: 13 | lisp: [sbcl-bin/2.4.0] 14 | target: [arm64, x86-64] 15 | steps: 16 | - uses: actions/checkout@v4 17 | - name: build 18 | env: 19 | LISP: ${{ matrix.lisp }} 20 | CFLAGS: -mmacosx-version-min=10.9 21 | CXXFLAGS: -mmacosx-version-min=10.9 22 | LDFLAGS: -mmacosx-version-min=10.9 23 | run: | 24 | brew install automake autoconf 25 | curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh 26 | make roswell-sbcl; mv roswell-sbcl sbcl 27 | make all archive 28 | - name: upload artifacts 29 | uses: actions/upload-artifact@v4 30 | with: 31 | name: ${{ matrix.target == 'arm64' && 'roswell-osx-arm64' || 'roswell-osx' }} 32 | path: ./*.tbz 33 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.fasl 3 | /sbcl 4 | /alpine-sbcl 5 | /roswell-sbcl 6 | /normal-sbcl 7 | /quicklisp 8 | /bin/lisp 9 | /bin/lisp.exe 10 | /sbcl.core 11 | /linkage-table-prelink-info-override.c 12 | /linkage-info.sexp 13 | lib/commit 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PREFIX?=/usr/local 2 | INSTALL_BIN=$(PREFIX)/bin 3 | LIBRARY_PATH=$(PREFIX)/lib 4 | TARGET=bin/lisp 5 | 6 | all: $(TARGET) 7 | 8 | install: lib/commit 9 | mkdir -p $(INSTALL_BIN) 10 | cp -f $(TARGET) $(INSTALL_BIN) 11 | mkdir -p $(LIBRARY_PATH)/roswell 12 | cp -r lib/* $(LIBRARY_PATH)/roswell 13 | 14 | uninstall: 15 | rm -rf $(LIBRARY_PATH)/roswell 16 | rm -f $(PREFIX)/$(TARGET) 17 | 18 | #### 19 | #dev. 20 | VERSION?=$(shell grep :version lib/roswell2.asd |sed 's/^.*"\(.*\)".*$$/\1/') 21 | # " lem fail 22 | ARCHIVE=roswell-$(VERSION)-$(shell uname -m)-$(shell uname -s) 23 | SBCL?=$(shell which sbcl) 24 | USER_ID?=$(shell id -u) 25 | GROUP_ID?=$(shell id -g) 26 | DOCKER_IMAGE?=roswell2 27 | DOCKER_BUILD_OPTION?= 28 | DOCKER_RUN_OPTION?= 29 | DOCKER_PLATFORM ?= linux/amd64 30 | 31 | # invoke linux 32 | # alpine for building environment. 33 | alpine-docker: 34 | echo "FROM alpine:3.18\\n"\ 35 | "run /bin/ash -c 'apk add --no-cache make sudo git shadow;" \ 36 | "adduser -S u;" \ 37 | "echo \"u ALL=(ALL) NOPASSWD:ALL\" >> /etc/sudoers;" \ 38 | "mkdir /tmp2;cd /tmp2;" \ 39 | "git clone https://github.com/roswell/roswell2 base;" \ 40 | "ln -s base/Makefile Makefile;" \ 41 | "ln -s base/bin bin;" \ 42 | "ln -s base/lib lib;" \ 43 | "make install-alpine alpine-sbcl;'" \ 44 | | docker build --platform $(DOCKER_PLATFORM) -t $(DOCKER_IMAGE) $(DOCKER_BUILD_OPTION) - 45 | 46 | alpine-docker-scratch: 47 | $(MAKE) DOCKER_BUILD_OPTION=--no-cache alpine-docker 48 | 49 | alpine: alpine-docker 50 | docker run -w /tmp3 -v $$PWD:/tmp3/base --rm --platform $(DOCKER_PLATFORM) -it $(DOCKER_IMAGE) $(DOCKER_RUN_OPTION) /bin/ash -c \ 51 | "ln -s base/Makefile Makefile; \ 52 | ln -s base/bin bin; \ 53 | ln -s base/lib lib; \ 54 | ln -s /tmp2/alpine-sbcl alpine-sbcl; \ 55 | ln -s /tmp2/sbcl.core sbcl.core; \ 56 | usermod -u $(USER_ID) u; \ 57 | addgroup -g $(GROUP_ID) u; \ 58 | usermod -g $(GROUP_ID) u; \ 59 | chown -R u:u .; \ 60 | sudo -u u /bin/ash -i" 61 | linux-build: alpine-docker 62 | docker run -w /tmp3 -v $$PWD:/tmp3/base --rm --platform $(DOCKER_PLATFORM) -i $(DOCKER_IMAGE) $(DOCKER_RUN_OPTION) /bin/ash -c \ 63 | "ln -s base/Makefile Makefile; \ 64 | ln -s base/bin bin; \ 65 | ln -s base/lib lib; \ 66 | ln -s /tmp2/alpine-sbcl alpine-sbcl; \ 67 | ln -s /tmp2/sbcl.core sbcl.core; \ 68 | usermod -u $(USER_ID) u; \ 69 | addgroup -g $(GROUP_ID) u; \ 70 | usermod -g $(GROUP_ID) u; \ 71 | chown -R u:u .; \ 72 | sudo -u u make" 73 | # ubuntu for testing environment. try not to copy bin to the environment. 74 | ubuntu: 75 | docker run -w /tmp2 -v $$PWD:/tmp2/base --rm --platform $(DOCKER_PLATFORM) -it ubuntu:16.04 $(DOCKER_RUN_OPTION) /bin/bash -c \ 76 | "apt-get update -y; \ 77 | apt-get install -y sudo make git bzip2; \ 78 | ln -s base/Makefile Makefile; \ 79 | ln -s base/bin bin; \ 80 | ln -s base/lib lib; \ 81 | /bin/bash -i" 82 | 83 | # install packages for environment need to launch with privilege 84 | install-alpine: 85 | apk add --no-cache alpine-sdk git linux-headers zlib-dev zlib-static \ 86 | curl-dev curl-static nghttp2-static openssl-libs-static brotli-static zlib-static libidn2-static libunistring-static 87 | if [ x`which sbcl` == x ]; then \ 88 | apk add --no-cache sbcl; \ 89 | git clone --depth 1 --branch=static-executable-v2-2.2.0 https://github.com/daewok/sbcl/ /tmp/sbcl || true; \ 90 | cd /tmp/sbcl; git apply /tmp2/base/patch-2.2.0; cd -; \ 91 | cd /tmp/sbcl; echo '"2.2.0-static"' > version.lisp-expr; cd -; \ 92 | cd /tmp/sbcl; sh make.sh --fancy --with-sb-linkable-runtime --with-sb-prelink-linkage-table; cd -; \ 93 | apk del --no-cache sbcl; \ 94 | cd /tmp/sbcl; sh install.sh; \ 95 | fi 96 | 97 | quicklisp/setup.lisp: 98 | git clone --depth 1 https://github.com/quicklisp/quicklisp-client.git quicklisp 99 | git clone --depth 1 https://github.com/roswell/cl-curl.git quicklisp/local-projects/cl-curl 100 | 101 | quicklisp/local-projects/cl-curl/curl.fasl: quicklisp/setup.lisp 102 | $(SBCL) \ 103 | --load quicklisp/setup.lisp \ 104 | --eval "(ql:quickload :cl-curl)" \ 105 | --eval "(asdf:operate 'asdf:monolithic-concatenate-source-op :cl-curl)" \ 106 | --load quicklisp/local-projects/cl-curl/curl.lisp \ 107 | --eval '(compile-file "quicklisp/local-projects/cl-curl/curl.lisp")' \ 108 | --quit 109 | 110 | linkage-info.sexp: quicklisp/local-projects/cl-curl/curl.fasl 111 | $(SBCL) --non-interactive \ 112 | --eval "(require :asdf)" \ 113 | --eval "(require :sb-posix)" \ 114 | --eval "(require :sb-md5)" \ 115 | --eval "(require :sb-bsd-sockets)" \ 116 | --eval "(require :sb-introspect)" \ 117 | --eval "(require :sb-cltl2)" \ 118 | --load $< \ 119 | --eval "(cl-curl:init)" \ 120 | --eval "#+unix(sb-alien:define-alien-routine (\"execvp\" %execvp) sb-alien:int(program sb-alien:c-string)(argv (* sb-alien:c-string)))" \ 121 | --load /tmp/sbcl/tools-for-build/dump-linkage-info.lisp \ 122 | --eval '(sb-dump-linkage-info:dump-to-file "$@")' \ 123 | --quit 124 | 125 | linkage-table-prelink-info-override.c: linkage-info.sexp 126 | $(SBCL) --script /tmp/sbcl/tools-for-build/create-linkage-table-prelink-info-override.lisp $< $@ 127 | 128 | %.o: %.c 129 | while read l; do \ 130 | eval "$${l%%=*}=\"$${l#*=}\""; \ 131 | done < /tmp/sbcl/src/runtime/sbcl.mk \ 132 | && $$CC $$CFLAGS -Wno-builtin-declaration-mismatch -o $@ -c $< 133 | 134 | sbcl.core: quicklisp/local-projects/cl-curl/curl.fasl 135 | $(SBCL) --non-interactive \ 136 | --eval "(require :asdf)" \ 137 | --eval "(require :sb-posix)" \ 138 | --eval "(require :sb-md5)" \ 139 | --eval "(require :sb-bsd-sockets)" \ 140 | --eval "(require :sb-introspect)" \ 141 | --eval "(require :sb-cltl2)" \ 142 | --load $< \ 143 | --eval "#+unix(sb-alien:define-alien-routine (\"execvp\" %execvp) sb-alien:int(program sb-alien:c-string)(argv (* sb-alien:c-string)))" \ 144 | --eval '(uiop:dump-image "$@" :compression t)' 145 | 146 | alpine-sbcl: linkage-table-prelink-info-override.o sbcl.core 147 | while read l; do \ 148 | eval "$${l%%=*}=\"$${l#*=}\""; \ 149 | done < /tmp/sbcl/src/runtime/sbcl.mk \ 150 | && $$CC -no-pie -static $$LINKFLAGS -o $@ /tmp/sbcl/src/runtime/$$LIBSBCL $< $$LIBS \ 151 | -static-libgcc -static-libstdc++ -lcurl -lnghttp2 -lssl -lcrypto -lz -lbrotlidec -lbrotlicommon -lidn2 -lunistring 152 | 153 | roswell-sbcl: 154 | $(MAKE) SBCL='ros run -L sbcl-bin +Q' sbcl.core 155 | ros run -L sbcl-bin --eval '(uiop:copy-file *runtime-pathname* "$@")' --quit 156 | chmod 755 $@ 157 | roswell2-sbcl: 158 | $(MAKE) SBCL='lisp run -L sbcl --native --' sbcl.core 159 | lisp run -Q -L sbcl --eval '(uiop:copy-file *runtime-pathname* "$@")' --quit 160 | chmod 755 $@ 161 | normal-sbcl: sbcl.core 162 | $(SBCL) \ 163 | --eval "(require :uiop)" \ 164 | --eval '(uiop:copy-file *runtime-pathname* "$@")' \ 165 | --quit 166 | chmod 755 $@ 167 | 168 | sbcl: 169 | @cp alpine-sbcl sbcl 2>/dev/null || \ 170 | (rm -f sbcl.core && $(MAKE) roswell-sbcl && cp roswell-sbcl sbcl 2>/dev/null) || \ 171 | (rm -f sbcl.core && $(MAKE) roswell2-sbcl && cp roswell2-sbcl sbcl 2>/dev/null) || \ 172 | (rm -f sbcl.core && $(MAKE) normal-sbcl && cp normal-sbcl sbcl 2>/dev/null) 173 | 174 | bin/ros.lisp: sbcl 175 | ./sbcl \ 176 | --eval '(uiop/configuration::compute-user-cache)' \ 177 | --eval '(asdf:load-asd (merge-pathnames "bin/roswell-bin.asd" (uiop:getcwd)))' \ 178 | --eval "(asdf:load-system :roswell-bin)" \ 179 | --eval '(asdf:make "roswell-bin")' \ 180 | --eval '(uiop:quit)' 181 | 182 | bin/ros.fasl: bin/ros.lisp 183 | ./sbcl \ 184 | --eval '(uiop/configuration::compute-user-cache)' \ 185 | --eval '(asdf:load-asd (merge-pathnames "bin/roswell-bin.asd" (uiop:getcwd)))' \ 186 | --eval "(asdf:load-system :roswell-bin)" \ 187 | --eval '(compile-file "$<")' \ 188 | --eval '(uiop:quit)' 189 | rm -f $< 190 | 191 | $(TARGET): bin/ros.fasl lib/commit 192 | ./sbcl \ 193 | --eval '(uiop/configuration::compute-user-cache)' \ 194 | --load bin/ros.fasl \ 195 | --eval "(roswell-bin/main:setup)" \ 196 | --eval "(setf uiop:*image-entry-point* (uiop:ensure-function \"roswell-bin/main:main\"))" \ 197 | --eval '(uiop:dump-image "$@" :executable t)' 198 | 199 | clean: 200 | rm -f linkage-info.sexp 201 | rm -rf quicklisp 202 | rm -f *.o 203 | rm -f linkage-table-prelink-info-override.c 204 | rm -f $(TARGET) 205 | 206 | archive: lib/commit 207 | mkdir $(ARCHIVE) 208 | mkdir $(ARCHIVE)/bin 209 | mkdir $(ARCHIVE)/lib 210 | cp $(TARGET) $(ARCHIVE)/bin 211 | cp -r lib/* $(ARCHIVE)/lib 212 | sed -n "/####/q;p" Makefile > $(ARCHIVE)/Makefile 213 | tar jcvf $(ARCHIVE).tbz $(ARCHIVE) 214 | 215 | lib/commit: 216 | echo $(shell cd lib;git show --format='%h %cd' --no-patch|| echo "unknown") > $@ 217 | 218 | install-for-test: 219 | make clean 220 | make 221 | make uninstall 222 | make install 223 | rm -rf ~/.cache/roswell/core/ 224 | 225 | .PHONY: alpine ubuntu clean install uninstall archive lib/commit 226 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # roswell2 2 | it's experiment to modernize roswell and implement all in common lisp. 3 | for portability purpose, roswell is kept maintained. 4 | 5 | # how to build. 6 | make; sudo make install 7 | 8 | # how to build on linux 9 | make linux-build; sudo make install 10 | 11 | # how to uninstall 12 | sudo make uninstall 13 | 14 | # rebuild core (you might need it if you update roswell2) 15 | lisp rebuild 16 | 17 | # launch sbcl 18 | lisp run -L sbcl 19 | 20 | # launch sbcl with quicklisp 21 | lisp run -L sbcl -Q 22 | 23 | # launch windows sbcl using wine.(quit immediately because --repl is not specified) 24 | lisp run -L sbcl --version 2.3.11 --os windows --arch x86-64 --wrap wine --eval "(print *features*)" 25 | 26 | # launch sbcl and print message and launch repl after eval. 27 | lisp run -L sbcl --eval '(print "hello world")' --repl 28 | -------------------------------------------------------------------------------- /bin/archive.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell-bin/archive 2 | (:use :cl 3 | :roswell-bin/util) 4 | (:export :tar)) 5 | (in-package :roswell-bin/archive) 6 | 7 | (defun extract-command-str (flags filename do-extract outputpath type) 8 | #-win32 9 | (cond ((or (equal type "gzip") 10 | (equal type "bzip2") 11 | (equal type "xz")) 12 | (let ((arc (or (which "gtar") 13 | (which "tar")))) 14 | (and arc 15 | (format nil "~A -dc ~A | ~A -~A~A~A" 16 | type 17 | filename 18 | arc 19 | (if do-extract "x" "t") 20 | (if flags "p" "f - -C ") 21 | outputpath)))) 22 | ((equal type "7za") 23 | (ensure-directories-exist outputpath) 24 | (format nil "7za ~A -o~A ~A" 25 | (if do-extract "x" "t") 26 | outputpath 27 | filename)) 28 | (t nil))) 29 | 30 | (defun extract (&key filename do-extract flags outputpath) 31 | (let ((ext (pathname-type filename)) 32 | (type "gzip")) 33 | (setf type (cond ((or (equal "tbz2" ext) 34 | (equal "bz2" ext)) 35 | "bzip2") 36 | ((equal "xz" ext) 37 | "xz") 38 | ((equal "7z" ext) 39 | "7za") 40 | ((equal "cab" ext) 41 | "cab") 42 | (t "gzip"))) 43 | (message :extract "extract type=~A" type) 44 | (let ((str (extract-command-str flags filename do-extract outputpath type))) 45 | (message :extract "extract cmd=~A" str) 46 | (when str 47 | (uiop:run-program str))))) 48 | 49 | (defun tar (args) 50 | (let (filename 51 | outputpath 52 | flags 53 | (mode #\x) 54 | (verbose 0)) 55 | (loop for argv on args 56 | while (eql (aref (car argv) 0) #\-) 57 | do (loop for p on (rest (coerce (car argv) 'list)) 58 | for opt = (first p) 59 | do (case opt 60 | (#\f 61 | (setf filename 62 | (if (rest p) 63 | (coerce (rest p) 'string) 64 | (second argv)) 65 | argv (if (rest p) 66 | argv 67 | (rest argv)) 68 | p nil)) 69 | (#\C 70 | (setf outputpath 71 | (if (rest p) 72 | (coerce (rest p) 'string) 73 | (second argv)) 74 | argv (if (rest p) 75 | argv 76 | (rest argv)) 77 | p nil)) 78 | (#\p 79 | (setf flags t)) 80 | ((#\t #\x) 81 | (setf mode opt)) 82 | (#\v 83 | (setf verbose (1+ (* verbose 2))))))) 84 | (extract :filename filename :do-extract (eql mode #\x) :flags flags :outputpath outputpath) 85 | 0)) 86 | -------------------------------------------------------------------------------- /bin/build.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell-bin/build 2 | (:use :cl 3 | :roswell-bin/config 4 | :roswell-bin/util 5 | :roswell-bin/uname 6 | :roswell-bin/install-quicklisp) 7 | (:export :build)) 8 | (in-package :roswell-bin/build) 9 | 10 | (defun build (args &key (cache-path (app-cachedir)) 11 | (config-path (app-configdir)) 12 | force) 13 | (message :build "build stage2 args => ~A path => ~A" args cache-path) 14 | (ensure-directories-exist config-path) 15 | (install-quicklisp :path cache-path :ql-path "quicklisp/") 16 | (message :build "build install quicklisp ~S done" config-path) 17 | (let ((asds-path (libdir)) 18 | (core-path (core-path cache-path))) 19 | (if (or (not (uiop:file-exists-p (ensure-directories-exist core-path))) 20 | force) 21 | (let ((invoke-list (list *stage1-path* 22 | "--eval" (format nil "(setf roswell-bin/util::*message-first-invocation* ~A roswell-bin/util:*verbose* ~A)" 23 | roswell-bin/util::*message-first-invocation* 24 | roswell-bin/util:*verbose*) 25 | "--load" (uiop:native-namestring (merge-pathnames "quicklisp/setup.lisp" cache-path)) 26 | "--eval" (format nil "(mapc (lambda (x) (asdf:load-asd x)) (directory \"~A*.asd\"))" asds-path) 27 | "--eval" "(let ((*standard-output* *error-output*)(*trace-output* *error-output*)) (ql:quickload :roswell2))" 28 | "--eval" (format nil "(let ((*standard-output* *error-output*)(*trace-output* *error-output*)) (roswell2/main:setup ~S ~S ~S))" config-path core-path asds-path)))) 29 | (message :build "build stage2 with ~S" invoke-list) 30 | (uiop:run-program invoke-list 31 | :output :interactive 32 | :error-output :interactive)) 33 | (message :build "build stage2 core found ~S" core-path)) 34 | (uiop:file-exists-p core-path))) 35 | -------------------------------------------------------------------------------- /bin/config.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell-bin/config 2 | (:use :cl) 3 | (:export :*project-name* :*stage1-path* :*stage1-commit* :*stage2-path* :*stage2-commit*)) 4 | (in-package :roswell-bin/config) 5 | 6 | (defparameter *project-name* "roswell") 7 | (defvar *stage1-path* nil) 8 | (defvar *stage1-commit* nil) 9 | (defvar *stage2-path* nil) 10 | (defvar *stage2-commit* nil) 11 | -------------------------------------------------------------------------------- /bin/download.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell-bin/download 2 | (:use :cl 3 | :roswell-bin/util) 4 | (:export :simple-fetch 5 | :lib-info :lib-init)) 6 | (in-package :roswell-bin/download) 7 | 8 | #-win32 9 | (cffi:defcallback write-data :size ((ptr :pointer) (size :size) 10 | (nmemb :size) (stream :pointer)) 11 | (let (#+nil(data-size (* size nmemb))) 12 | (cl-curl/functions::fwrite ptr size nmemb stream))) 13 | 14 | #-win32 15 | (cffi:defcallback header-callback :size ((buffer :pointer) (size :size) 16 | (nmemb :size) (stream :pointer)) 17 | (declare (ignorable stream buffer)) 18 | (* size nmemb)) 19 | 20 | (defun simple-fetch (uri path &key &allow-other-keys) 21 | (message :simple-fetch "download uri ~A path ~A" uri path) 22 | #-win32 23 | (let* ((part (format nil "~A.part" path)) 24 | (bodyfile (cl-curl/functions::fopen part "wb")) 25 | res) 26 | (unless (cffi:null-pointer-p bodyfile) 27 | (let ((curl (cl-curl:curl-easy-init))) 28 | (unless (cffi:null-pointer-p curl) 29 | (unwind-protect 30 | (progn 31 | (cl-curl:curl-easy-setopt curl :url uri) 32 | (cl-curl:curl-easy-setopt curl :followlocation 1) 33 | (cl-curl:curl-easy-setopt curl :writefunction (cffi:callback write-data)) 34 | (cl-curl:curl-easy-setopt curl :headerfunction (cffi:callback header-callback)) 35 | (cl-curl:curl-easy-setopt curl :writedata bodyfile) 36 | (setf res (cl-curl:curl-easy-perform curl))) 37 | (cl-curl:curl-easy-cleanup curl) 38 | (cl-curl/functions::fclose bodyfile) 39 | (uiop:rename-file-overwriting-target part path)) 40 | (unless (zerop res) 41 | (return-from simple-fetch 2)))))) 42 | 0) 43 | 44 | (defun lib-info () 45 | #-win32 46 | (loop for elt in (uiop:split-string (cl-curl:curl-version) :separator '(#\Space)) 47 | for split = (uiop:split-string (string-trim "()" elt) :separator '(#\/)) 48 | collect (cons "libcurl" split))) 49 | 50 | (defun lib-init () 51 | #-(and linux) 52 | (cl-curl:init) 53 | ) 54 | -------------------------------------------------------------------------------- /bin/install-quicklisp.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell-bin/install-quicklisp 2 | (:use :cl 3 | :roswell-bin/config 4 | :roswell-bin/util 5 | :roswell-bin/download 6 | :roswell-bin/archive) 7 | (:export :install-quicklisp)) 8 | (in-package :roswell-bin/install-quicklisp) 9 | 10 | (defvar *quicklisp-client-version-uri* 11 | "https://raw.githubusercontent.com/quicklisp/quicklisp-client/master/quicklisp/version.txt") 12 | 13 | (defvar *quicklisp-client-archive-uri* 14 | "https://github.com/quicklisp/quicklisp-client/archive/refs/tags/version-~A.tar.gz") 15 | 16 | (defun quicklisp-client-version (&key (uri *quicklisp-client-version-uri*) 17 | (path (app-cachedir))) 18 | "=> \"2021-02-13\"" 19 | (let ((file-path (ensure-directories-exist (merge-pathnames "tmp/quicklisp-client.version" path)))) 20 | (simple-fetch uri file-path) 21 | (uiop:read-file-line file-path))) 22 | 23 | (defun quicklisp-client-archive (&key version 24 | (cache-path (app-cachedir))) 25 | (let* ((version (or version (quicklisp-client-version :path cache-path))) 26 | (archive-uri (format nil *quicklisp-client-archive-uri* version)) 27 | (file-path (ensure-directories-exist (merge-pathnames (format nil "archives/qlcli-~A.tgz" version) cache-path)))) 28 | (unless (uiop:file-exists-p file-path) 29 | (simple-fetch archive-uri file-path)) 30 | (values file-path version))) 31 | 32 | (defun install-quicklisp (&key 33 | version 34 | (dist-url "http://beta.quicklisp.org/dist/quicklisp.txt") 35 | (path (app-cachedir)) 36 | (ql-path "quicklisp/")) 37 | (let ((ql-path (merge-pathnames ql-path (ensure-directories-exist path))) 38 | (libpath (libdir))) 39 | (if (uiop:directory-exists-p ql-path) 40 | (message :install-quicklisp "~S found" ql-path) 41 | (multiple-value-bind (file-path version) 42 | (quicklisp-client-archive :version version) 43 | (tar 44 | (list "-xf" file-path 45 | "-C" (uiop:native-namestring path))) 46 | (let ((orig-dir (first (directory (format nil "~A*~A" (uiop:native-namestring path) version))))) 47 | (message :quicklisp-client-archive "rename '~A' => '~A'" orig-dir ql-path) 48 | (rename-file 49 | orig-dir 50 | ql-path)) 51 | (message :quicklisp-client-archive "set dist dir for '~A' = '~A'" ql-path dist-url) 52 | (uiop:run-program (list *stage1-path* 53 | "--eval" "(defpackage :quicklisp-quickstart)" 54 | "--eval" (format nil "(defvar quicklisp-quickstart::*quickstart-parameters* (list :initial-dist-url ~S))" dist-url) 55 | "--eval" (format nil "(let ((*standard-output* *error-output*)(*trace-output* *error-output*))(load (uiop:native-namestring (merge-pathnames \"setup.lisp\" ~S))))" 56 | ql-path) 57 | "--eval" "(uiop:quit)") 58 | :ignore-error-status t 59 | :output :interactive 60 | :error-output :interactive))) 61 | ;; copy extension 62 | (let* ((extension "roswell.quicklisp.extensions") 63 | (loader (ensure-directories-exist (merge-pathnames "local-init/roswell2.lisp" ql-path))) 64 | (lisp (format nil "~A.lisp" extension)) 65 | (asd (format nil "~A.asd" extension))) 66 | ;; shouldn't automatically load. 67 | #+() 68 | (unless (uiop:file-exists-p loader) 69 | (with-open-file (o loader :direction :output) 70 | (format o "#+roswell2.init(asdf:load-system ~S)~%" extension))) 71 | (loop for file in (list lisp asd) 72 | for src = (merge-pathnames file libpath) 73 | for dest = (merge-pathnames (format nil "quicklisp/~A" file) ql-path) 74 | do (when (or (not (uiop:file-exists-p dest)) 75 | (> (file-write-date src) 76 | (file-write-date dest))) 77 | (uiop:copy-file src dest)))))) 78 | -------------------------------------------------------------------------------- /bin/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell-bin/main 2 | (:use :cl 3 | :roswell-bin/config 4 | :roswell-bin/util 5 | :roswell-bin/uname 6 | :roswell-bin/download 7 | :roswell-bin/build) 8 | (:export :main :setup)) 9 | 10 | (in-package :roswell-bin/main) 11 | 12 | (defun internal (args) 13 | "functionality which is difficult to implement without ffi or external commands. stage-2 can invoke it for implement installers." 14 | (message :internal "message args = ~S" args) 15 | (let* ((arg (first args)) 16 | (args (rest args))) 17 | (cond 18 | ((equal arg "rebuild") 19 | (build nil :force t) 20 | (uiop:quit 0)) 21 | ((equal arg "head") 22 | (message :internal "not implementead head")) 23 | ((equal arg "uname") 24 | (uname args)) 25 | ((equal arg "which") 26 | (let ((result (which (first args)))) 27 | (if result (prog1 0 (format t "~A~%" result)) 28 | 1))) 29 | ((equal arg "man") 30 | (message :internal "not implementead man")) 31 | ((equal arg "impl") 32 | (message :internal "not implementead impl")) 33 | ((equal arg "version") 34 | (message :internal "not implementead version"))))) 35 | 36 | (defun invoke-stage2 (args) 37 | (let* ((core (build nil)) 38 | (invoke-list `(,(format nil "~A" core) 39 | "--eval" 40 | ,(format nil "(setf roswell-bin/util::*message-first-invocation* ~A)" 41 | roswell-bin/util::*message-first-invocation*) 42 | ,@(unless (zerop roswell-bin/util:*verbose*) 43 | (list (format nil "-~v@{v~}" roswell-bin/util:*verbose* nil))) 44 | ,@args))) 45 | (message :main "args: ~S core: ~S" args core) 46 | (message :main "invoke-list ~S" invoke-list) 47 | (exec invoke-list) 48 | ;; in case 49 | (uiop:quit 1))) 50 | 51 | (defun setup () 52 | (sb-posix:unsetenv "P") 53 | (setf *stage1-commit* (uiop:read-file-line "lib/commit")) 54 | (lib-init) 55 | (strip-run-cmd nil) ;; clear all cache 56 | (uname-s) 57 | (uname-m)) 58 | 59 | (defun main () 60 | (setup-uid :euid t) 61 | #+nil(print (list :uid (sb-posix:getuid) 62 | :gid (sb-posix:getgid) 63 | :euid (sb-posix:geteuid) 64 | :egid (sb-posix:getegid))) 65 | #+nil(print (uiop/image:raw-command-line-arguments)) 66 | #+nil(print (list :sbcl-homedir sb-sys::*sbcl-homedir-pathname*)) 67 | #+nil(print (list :homedir (user-homedir))) 68 | (setf *stage1-path* sb-ext:*runtime-pathname*) 69 | (loop for args on (rest (uiop/image:raw-command-line-arguments)) 70 | for arg = (first args) 71 | do (cond ((equal arg "roswell-internal-use") 72 | (uiop:quit (internal (rest args)))) 73 | ((equal arg "rebuild") 74 | (build nil :force t) 75 | (uiop:quit 0)) 76 | ((find arg '("--load" "-l") :test 'equal) 77 | (load (second args)) 78 | (setf args (rest args))) 79 | ((find arg '("--verbose" "-v") :test 'equal) 80 | (incf roswell-bin/util:*verbose*)) 81 | ((find arg '("--eval" "-e") :test 'equal) 82 | (eval (read-from-string (second args))) 83 | (setf args (rest args))) 84 | (t 85 | (when (equal (car args) "--") 86 | (setf args (cdr args))) 87 | (invoke-stage2 args))) 88 | finally (invoke-stage2 args))) 89 | -------------------------------------------------------------------------------- /bin/roswell-bin.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell-bin" 2 | :class :package-inferred-system 3 | :depends-on (:roswell-bin/main) 4 | :build-operation monolithic-concatenate-source-op 5 | :build-pathname "ros" 6 | :entry-point "roswell-bin/main:main") 7 | -------------------------------------------------------------------------------- /bin/uname.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell-bin/uname 2 | (:use :cl 3 | :roswell-bin/util) 4 | (:export :uname-s 5 | :uname-m 6 | :exeext 7 | :core-path 8 | :uname)) 9 | (in-package :roswell-bin/uname) 10 | 11 | (defun uname-s () 12 | #-win32 13 | (let ((s (strip-run-cmd "uname -s" :cache t))) 14 | (cond ((equal s "SunOS") "solaris") 15 | ((equal s "DragonFly") "DFlyBSD") 16 | ((and (equal s "Linux") 17 | (equal (strip-run-cmd "uname -m" :cache t) 18 | "aarch64") 19 | (equal (strip-run-cmd "uname -o" :cache t) 20 | "Android")) 21 | ;; termux? 22 | "android") 23 | (t (string-downcase s))))) 24 | 25 | (defun uname-m () 26 | (let ((m (strip-run-cmd "uname -m" :cache t))) 27 | (cond ((equal m "x86_64") 28 | (or 29 | #+darwin 30 | (when (equal (strip-run-cmd "sysctl -in sysctl.proc_translated" :cache t) 31 | "1") 32 | "arm64") ;;rosetta 33 | "x86-64")) 34 | ((equal m "i86pc") 35 | ;; solaris 36 | (if (equal (strip-run-cmd "isainfo -k" :cache t) 37 | "amd64") 38 | "x86-64" 39 | "x86")) 40 | ((or (equal m "i686") 41 | (equal m "i386")) 42 | "x86") 43 | ((equal m "amd64") 44 | "x86-64") 45 | ((equal m "aarch64") 46 | "arm64") 47 | ((or (equal m "armv6l") 48 | (equal m "armv7l")) 49 | (let ((result (strip-run-cmd "readelf -A /proc/self/exe |grep Tag_ABI_VFP_args|wc -l" :cache t))) 50 | (if (equal "0" result) 51 | "armhf" 52 | "armel"))) 53 | ((or (equal m "armv5tejl") 54 | (equal m "armel")) 55 | t) 56 | (t 57 | (substitute #\- #\_ m))))) 58 | 59 | (defun exeext () 60 | #-win32"") 61 | 62 | (defun core-path (base-path) 63 | (merge-pathnames (format nil "core/~A/~A/roswell~A" 64 | (uname-m) 65 | (uname-s) 66 | (exeext)) base-path)) 67 | 68 | (defun uname (args) 69 | (cond ((or (equal (first args) "-s") 70 | (null (first args))) 71 | (format t "~A~%" (uname-s))) 72 | ((equal (first args) "-m") 73 | (format t "~A~%" (uname-m))) 74 | (t 75 | (error "uname error ~S" args)))) 76 | -------------------------------------------------------------------------------- /bin/util.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell-bin/util 2 | (:use :cl :roswell-bin/config) 3 | (:export :message 4 | :strip-run-cmd 5 | :which 6 | :libdir 7 | :user-homedir 8 | :chdir 9 | :app-configdir 10 | :app-cachedir 11 | :setup-uid 12 | :subseq* 13 | :run-program 14 | :exec 15 | :*verbose* 16 | )) 17 | 18 | (in-package :roswell-bin/util) 19 | 20 | (defvar *message* 'message-func) 21 | (defvar *message-first-invocation* nil) 22 | (defvar *verbose* 0) 23 | 24 | (defun message-func (level fmt &rest params) 25 | (declare (ignorable level)) 26 | (unless (zerop *verbose*) 27 | (format *error-output* "~&[~8,4f]" 28 | (float (/ (- (get-internal-run-time) *message-first-invocation*) 29 | internal-time-units-per-second))) 30 | (apply #'format *error-output* fmt params) 31 | (terpri *error-output*))) 32 | 33 | (defun message (&rest r) 34 | (unless *message-first-invocation* 35 | (setf *message-first-invocation* (get-internal-run-time))) 36 | (apply *message* r) 37 | nil) 38 | 39 | (defvar *strip-run-cmd-hash* (make-hash-table :test 'equal)) 40 | 41 | (defun strip-run-cmd (cmd &key cache) 42 | (cond (cmd 43 | (unless cache 44 | (remhash cmd *strip-run-cmd-hash*)) 45 | (if (eql (gethash cmd *strip-run-cmd-hash* t) t) 46 | (setf (gethash cmd *strip-run-cmd-hash*) 47 | (uiop:run-program 48 | cmd 49 | :output '(:string :stripped t) 50 | :ignore-error-status t)) 51 | (gethash cmd *strip-run-cmd-hash*))) 52 | (t 53 | (setf *strip-run-cmd-hash* (make-hash-table :test 'equal))))) 54 | 55 | (defun which (cmd) 56 | "find out command's full path." 57 | (let* ((which-cmd #-win32(format nil "command -v ~S" cmd) 58 | #+win32(format nil "cmd /c where ~S" cmd)) 59 | (result (strip-run-cmd which-cmd))) 60 | (message :which "which '~A' -> '~A'" cmd result) 61 | (setf result (unless (zerop (length result)) 62 | result)) 63 | result)) 64 | 65 | (defun libdir () 66 | (truename 67 | (merge-pathnames "../lib/roswell/" 68 | (make-pathname :defaults *stage1-path* :name nil :type nil)))) 69 | 70 | (defun user-homedir () 71 | "tweeked user-homedir-pathname" 72 | #-win32 73 | (let* ((user (uiop:getenv "SUDO_USER")) 74 | (uid (sb-posix:getuid)) 75 | (pwd (sb-posix:getpwuid uid))) 76 | (when (and user (zerop uid)) 77 | (setf pwd (sb-posix:getpwnam user))) 78 | (parse-namestring (format nil "~A/" (sb-posix:passwd-dir pwd)))) 79 | #+win32 80 | (parse-native-namestring (sb-win32::get-folder-namestring sb-win32::csidl_profile))) 81 | 82 | (defun app-configdir () 83 | "Return directory which this applicatation freely read/write 84 | to setup implementations and libraries" 85 | (let* ((env (uiop:getenv "XDG_CONFIG")) ;;expect $HOME/.config 86 | (result (or (when env 87 | (parse-namestring (format nil "~A/~A/" env *project-name*))) 88 | (merge-pathnames (format nil 89 | #-win32 ".config/~A/" 90 | #+win32 "config/~A/" 91 | *project-name*) 92 | (user-homedir))))) 93 | (message :app-configdir "app-configdir => ~A" result) 94 | result)) 95 | 96 | (defun app-cachedir () 97 | "return directory which might be not important" 98 | (let* ((env (uiop:getenv "XDG_CACHE_HOME")) ;;expect $HOME/.cache 99 | (result (or (when env 100 | (parse-namestring (format nil "~A/~A/" env *project-name*))) 101 | (merge-pathnames (format nil ".cache/~A/" *project-name*) 102 | (user-homedir))))) 103 | (message :app-configdir "app-cachedir => ~A" result) 104 | result)) 105 | 106 | (defun chdir (dir) 107 | (message :chdir "chdir: ~S" dir) 108 | (uiop:chdir dir)) 109 | 110 | (defun setup-uid (&key euid) 111 | "Drop Privileges" 112 | #-(or win32 android) 113 | (when (zerop (sb-posix:getuid)) 114 | (let* ((uid (ignore-errors (parse-integer (uiop:getenv "SUDO_UID")))) 115 | (gid (ignore-errors (parse-integer (uiop:getenv "SUDO_GID"))))) 116 | (if euid 117 | (and 118 | (and gid (sb-posix:setegid gid)) 119 | (and uid (sb-posix:seteuid uid))) 120 | (and 121 | (and gid (sb-posix:setgid gid)) 122 | (and uid (sb-posix:setuid uid)))))) 123 | t) 124 | (defun subseq* (seq start &optional end) 125 | (let ((len (length seq))) 126 | (and end 127 | (minusp end) 128 | (setf end (+ len end))) 129 | (and start 130 | (minusp start) 131 | (setf start (+ len start))) 132 | (subseq seq (max 0 start) (and end (min end len))))) 133 | 134 | #+unix 135 | (progn ;from swank 136 | (sb-alien:define-alien-routine ("execvp" %execvp) sb-alien:int 137 | (program sb-alien:c-string) 138 | (argv (* sb-alien:c-string))) 139 | (defun execvp (program args) 140 | "Replace current executable with another one." 141 | (let ((a-args (sb-alien:make-alien sb-alien:c-string 142 | (+ 1 (length args))))) 143 | (unwind-protect 144 | (progn 145 | (loop for index from 0 by 1 146 | and item in (append args '(nil)) 147 | do (setf (sb-alien:deref a-args index) 148 | item)) 149 | (when (minusp 150 | (%execvp program a-args)) 151 | (let ((errno (sb-impl::get-errno))) 152 | (case errno 153 | (2 (error "No such file or directory: ~S" program)) 154 | (otherwise 155 | (error "execvp(3) failed. (Code=~D)" errno)))))) 156 | (sb-alien:free-alien a-args))))) 157 | 158 | (defun run-program (args) 159 | (uiop:run-program args 160 | :output :interactive 161 | :error-output :interactive)) 162 | 163 | (defun exec (args) 164 | "Launch executable" 165 | #+unix 166 | (execvp (first args) args) 167 | (uiop:quit (run-program args))) 168 | -------------------------------------------------------------------------------- /lib/clingon.extensions.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2/clingon.extensions 2 | (:use :cl 3 | :roswell-bin/util) 4 | (:import-from :clingon)) 5 | (in-package :roswell2/clingon.extensions) 6 | 7 | 8 | ;;extend options 9 | (defclass option-filter (clingon:option) 10 | ((filter 11 | :initarg :filter 12 | :initform #'identity 13 | :reader option-filter)) 14 | (:documentation "An option which collects values into a list")) 15 | 16 | (defmethod clingon:derive-option-value :around ((option option-filter) arg &key) 17 | (funcall (option-filter option) (call-next-method) option)) 18 | 19 | (defmethod clingon:make-option ((kind (eql :option-filter)) &rest rest) 20 | (apply #'make-instance 'option-filter rest)) 21 | 22 | (defclass option-counter-filter (clingon:option-counter option-filter) 23 | ()) 24 | 25 | (defmethod clingon:make-option ((kind (eql :counter-filter)) &rest rest) 26 | (apply #'make-instance 'option-counter-filter rest)) 27 | 28 | 29 | ;;extend commands 30 | 31 | (defclass command-without-version (clingon:command) ()) 32 | 33 | (defmethod initialize-instance :after ((command command-without-version) &key) 34 | (setf (clingon:command-options command) 35 | (remove clingon.command:*default-version-flag* 36 | (clingon:command-options command) 37 | :test 'equal))) 38 | 39 | (defclass command-accept-slash-sepalated-subcommand (clingon:command) 40 | ()) 41 | 42 | (defmethod clingon.command:find-sub-command ((command command-accept-slash-sepalated-subcommand) 43 | name) 44 | "Returns the sub-command with the given name or alias" 45 | (let* ((pos (position #\/ name)) 46 | (val (and pos (subseq name (1+ pos)))) 47 | (name (subseq name 0 pos))) 48 | (find-if (lambda (sub-command) 49 | (let ((result 50 | (or (string= name (clingon:command-name sub-command)) 51 | (member name (clingon:command-aliases sub-command) :test #'string=)))) 52 | (when (and pos result) 53 | (setf (clingon:command-args-to-parse command) 54 | `(,(first (clingon:command-args-to-parse command)) 55 | "--version" 56 | ,val 57 | ,@(rest (clingon:command-args-to-parse command))))) 58 | result)) 59 | (clingon:command-sub-commands command)))) 60 | 61 | (defclass stop-parse-when-free-argument-comes-command (clingon:command) 62 | ()) 63 | 64 | (defmethod clingon.command:find-sub-command ((command stop-parse-when-free-argument-comes-command) 65 | name) 66 | "stop parsing if get non option" 67 | (cond 68 | ((or (clingon:short-option-p name) 69 | (clingon:long-option-p name)) 70 | nil) 71 | ((find-if (lambda (sub-command) 72 | (or (string= name (clingon.command:command-name sub-command)) 73 | (member name (clingon.command:command-aliases sub-command) :test #'string=))) 74 | (clingon.command:command-sub-commands command))) 75 | (t ;;stop evaluating. if not option. 76 | (setf (clingon:command-args-to-parse command) 77 | `("*" ,@(if (equal "--" name) nil (list "--")) 78 | ,@(clingon:command-args-to-parse command))) 79 | (make-instance 80 | 'clingon.command:command 81 | :name name 82 | :handler (clingon.command:command-handler command) 83 | :parent command)))) 84 | 85 | (defclass install-command (command-without-version 86 | command-accept-slash-sepalated-subcommand) 87 | ()) 88 | 89 | (defclass run-command (command-without-version 90 | stop-parse-when-free-argument-comes-command) 91 | ()) 92 | 93 | (defclass root-command (clingon:command) ()) 94 | 95 | (defmethod clingon:print-version ((command root-command) stream &key) 96 | (when (clingon:command-version command) 97 | (format stream 98 | "roswell ~A()~&" 99 | (clingon:command-version command)))) 100 | -------------------------------------------------------------------------------- /lib/config.default.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2/config.default 2 | (:use :cl)) 3 | (in-package :roswell2/config.default) 4 | 5 | #+linux 6 | (when (uiop:file-exists-p "/etc/alpine-release") 7 | (setf roswell2.install.sbcl:*default-variant* "musl")) 8 | -------------------------------------------------------------------------------- /lib/config/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.cmd.config/main 2 | (:use :cl) 3 | (:use :cl 4 | :roswell-bin/util 5 | :roswell-bin/uname 6 | :roswell2/main 7 | :roswell2.cmd.run) 8 | (:nicknames :roswell2.cmd.config) 9 | (:import-from :clingon)) 10 | 11 | (in-package :roswell2.cmd.config/main) 12 | 13 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 14 | 15 | (defun options () 16 | (list 17 | (clingon:make-option 18 | :boolean/true 19 | :persistent t 20 | :description "use user config file" 21 | :long-name "user" 22 | :category "Config file location" 23 | :key :user) 24 | (clingon:make-option 25 | :boolean/true 26 | :persistent t 27 | :description "use local config file" 28 | :long-name "local" 29 | :category "Config file location" 30 | :key :local))) 31 | 32 | (defun sub-commands () 33 | (list 34 | (make-instance 35 | 'roswell2/clingon.extensions::command-without-version 36 | :name "show" 37 | :description "show config" 38 | :handler 'show))) 39 | 40 | (defun config-file (cmd) 41 | (let ((count (count-if (complement #'null) '(:local :user) 42 | :key (lambda (x) (clingon:getopt cmd x))))) 43 | (when (> count 1) 44 | (format *error-output* "too much location options~%") 45 | (return-from config-file nil)) 46 | (load-config :where 47 | (cond ((clingon:getopt cmd :user) 48 | :user) 49 | ((clingon:getopt cmd :local) 50 | :local) 51 | (t :user))))) 52 | 53 | (defun handler (cmd) 54 | (multiple-value-bind (config path) 55 | (config-file cmd) 56 | (let ((orig-result (config-to-string config))) 57 | (loop for arg in (clingon:command-arguments cmd) 58 | for split = (uiop:split-string arg :separator '(#\=)) 59 | for left = (first split) 60 | for right = (second split) 61 | do (and left right 62 | (setf (config (uiop:split-string left :separator '(#\.)) 63 | config) 64 | (if (equal right "") 65 | nil 66 | right)))) 67 | (let ((new-result (config-to-string config))) 68 | (unless (equal orig-result new-result) 69 | (with-open-file (o path :direction :output :if-exists :supersede) 70 | (format o "~A~%" new-result))))) 71 | (unless (clingon:command-arguments cmd) 72 | (clingon:run cmd '("--help"))))) 73 | 74 | (defun show (cmd) 75 | (multiple-value-bind (config path) 76 | (config-file cmd) 77 | (message :config-show "config: ~A path: ~A" config path) 78 | (when path 79 | (if (uiop:file-exists-p path) 80 | (with-open-file (in path) 81 | (format t "~A" (uiop:read-file-string in))) 82 | (progn 83 | (format *error-output* "~A not exists.~%" path)))))) 84 | -------------------------------------------------------------------------------- /lib/config/roswell2.cmd.config.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.cmd.config" 2 | :long-name "config" 3 | :class :package-inferred-system 4 | :version "23.8.15.114" 5 | :author "SANO Masatoshi" 6 | :description "edit show configuration" 7 | :license "MIT" 8 | :depends-on (:roswell2.cmd.config/main)) 9 | -------------------------------------------------------------------------------- /lib/impl/install/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.impl.install/main 2 | (:use :cl 3 | :roswell-bin/util 4 | :roswell2/main) 5 | (:nicknames :roswell2.impl.install) 6 | (:import-from :clingon) 7 | (:export :sh 8 | :option-base 9 | :install 10 | :impl-set-version-param 11 | :impl-save-config 12 | :install-impl-param)) 13 | 14 | (in-package :roswell2.impl.install/main) 15 | 16 | (defvar *command-class* 'roswell2/clingon.extensions::install-command) 17 | 18 | (defun options () 19 | "Returns the options for the command" 20 | (list)) 21 | 22 | (defclass install-impl-param (impl-param) 23 | ((config-location 24 | :initarg :config-location 25 | :initform nil 26 | :reader impl-param-config-location))) 27 | 28 | (defun option-base (&key variant-explanation 29 | base-uri-explanation 30 | arch-explanation 31 | os-explanation) 32 | (list 33 | (clingon:make-option 34 | :string 35 | :description arch-explanation 36 | :parameter "ARCH" 37 | :long-name "arch" 38 | :key :arch) 39 | (clingon:make-option 40 | :string 41 | :description variant-explanation 42 | :parameter "VARIANT" 43 | :long-name "variant" 44 | :key :variant) 45 | (clingon:make-option 46 | :string 47 | :description os-explanation 48 | :parameter "OS" 49 | :long-name "os" 50 | :key :os) 51 | (clingon:make-option 52 | :string 53 | :description "set version for install" 54 | :parameter "VERSION" 55 | :long-name "version" 56 | :key :version) 57 | (clingon:make-option 58 | :string 59 | :description base-uri-explanation 60 | :parameter "URI" 61 | :long-name "base-uri" 62 | :key :base-uri) 63 | (clingon:make-option 64 | :string 65 | :description (format nil "set archive uri") 66 | :parameter "URI" 67 | :long-name "uri" 68 | :key :uri) 69 | (clingon:make-option 70 | :string 71 | :description (format nil "set local archive to install instead of downloading from The internet.") 72 | :parameter "archivefile" 73 | :long-name "archive" 74 | :key :archive) 75 | (clingon:make-option 76 | :string 77 | :description "edit config to use the implementation as default (user/local/none)" 78 | :long-name "config-location" 79 | :key :config-location) 80 | )) 81 | 82 | (defmethod impl-set-version-param ((param impl-param))) 83 | 84 | (defun sub-commands () 85 | (sub-command-filter "roswell2.install.")) 86 | 87 | (defun handler (cmd) 88 | "Handler for just evaluate options" 89 | (let ((args (clingon:command-arguments cmd))) 90 | (message :main-handler "args-for install handler ~S" args) 91 | (cond ((null args) 92 | (clingon:run cmd '("--help"))) 93 | (t))) 94 | (uiop:quit)) 95 | 96 | (defun sh () 97 | (or (which "bash") 98 | "sh")) 99 | 100 | (defun impl-save-config (param) 101 | (message :impl-save-config "impl-save-config param:~S" param) 102 | (let* ((where (slot-value param 'config-location)) 103 | (variant (impl-param-variant* param)) 104 | (version (impl-param-version param)) 105 | (config (when where (load-config :where where))) 106 | (name (impl-param-name param))) 107 | (when where 108 | (unless (config `(,name "variant") config :if-does-not-exist nil) 109 | (setf (config `(,name "variant") config) variant)) 110 | (unless (config `(,name "version") config :if-does-not-exist nil) 111 | (setf (config `(,name "version") config) version)) 112 | (save-config :config config :where where)) 113 | (setf (slot-value param 'config-location) nil) 114 | (with-open-file (o (merge-pathnames "roswell.sexp" (impl-path param)) 115 | :direction :output 116 | :if-exists :supersede) 117 | (format o "~S~%" param)))) 118 | 119 | (defmethod install :after ((param install-impl-param)) 120 | (message :install-after "install after ~S" param) 121 | (impl-save-config param)) 122 | 123 | (defmethod impl-set-param :after ((param install-impl-param) cmd) 124 | (message :impl-set-param "set config-location ~S" (clingon:getopt cmd :config-location)) 125 | (setf (slot-value param 'config-location) 126 | (let ((place (clingon:getopt cmd :config-location))) 127 | (cond ((null place) :user) 128 | ((equalp place "user") :user) 129 | ((equalp place "local") :local) 130 | (t nil))))) 131 | -------------------------------------------------------------------------------- /lib/impl/install/roswell2.impl.install.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.impl.install" 2 | :long-name "install" 3 | :class :package-inferred-system 4 | :author "SANO Masatoshi" 5 | :description "Install implementation" 6 | :license "MIT" 7 | :depends-on (:roswell2.impl.install/main)) 8 | -------------------------------------------------------------------------------- /lib/impl/install/sbcl/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.install.sbcl/main 2 | (:use :cl 3 | :roswell-bin/archive 4 | :roswell-bin/download 5 | :roswell-bin/util 6 | :roswell-bin/uname 7 | :roswell2.impl.install 8 | :roswell2/main) 9 | (:nicknames :roswell2.install.sbcl) 10 | (:import-from :clingon) 11 | (:export 12 | :*base-uri* 13 | :*default-variant* 14 | :sbcl-impl-param)) 15 | 16 | (in-package :roswell2.install.sbcl/main) 17 | 18 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 19 | (defvar *base-uri* "https://github.com/roswell/sbcl_bin/releases/download/") 20 | (defvar *uri-found-in-tsv* nil) 21 | (defvar *vanilla* "bin") 22 | (defvar *default-variant* *vanilla*) 23 | 24 | (defun options () 25 | "Returns the options for the command" 26 | (option-base 27 | :variant-explanation (format nil "set variant for install. default:~A https://github.com/roswell/sbcl_bin/blob/master/table.md" *default-variant*) 28 | :base-uri-explanation (format nil "set base-uri default:~A" *base-uri*) 29 | :arch-explanation (format nil "set arch for install. defualt:~A" (uname-m)) 30 | :os-explanation (format nil "set os for install. default:~A" (uname-s)))) 31 | 32 | (defclass sbcl-impl-param (install-impl-param) 33 | ()) 34 | 35 | (defun impl-tsv-uri (param) 36 | (format nil "~Afiles/sbcl-bin_uri.tsv" (or (impl-param-base-uri param) *base-uri*))) 37 | 38 | (defmethod impl-set-version-param ((param sbcl-impl-param)) 39 | (let* ((tsv-uri (impl-tsv-uri param)) 40 | (tsv-path (merge-pathnames (format nil "tmp/~A" (file-namestring tsv-uri)) (app-cachedir)))) 41 | (ensure-directories-exist tsv-path) 42 | (message :impl-set-version-param "No ~A version specified. Downloading ~A to see the available versions..." 43 | (impl-param-name param) 44 | (file-namestring tsv-uri)) 45 | (let ((code (simple-fetch tsv-uri tsv-path))) 46 | (unless (zerop code) 47 | (message :impl-set-version-param "Download failed (Code=~A)" code) 48 | (return-from impl-set-version-param 1))) 49 | (loop for line in (cdr (uiop:read-file-lines tsv-path)) 50 | for split = (uiop:split-string line) 51 | for system = (first split) 52 | for arch = (second split) 53 | for version = (third split) 54 | for variant = (fourth split) 55 | for uri = (fifth split) 56 | for param-variant = (impl-param-variant* param) 57 | do (when (and (equal variant (if (equal param-variant *vanilla*) 58 | "" 59 | param-variant)) 60 | (equal (impl-param-os* param) system) 61 | (equal (impl-param-arch* param) arch)) 62 | (setf (impl-param-version param) version) 63 | (setf *uri-found-in-tsv* uri) 64 | (message :impl-set-version-param "Installing ~A/~A..." 65 | (impl-param-name param) 66 | (impl-param-version param)) 67 | (return-from impl-set-version-param param))) 68 | (return-from impl-set-version-param 1))) 69 | 70 | (defun impl-already-installedp (param) 71 | ;;return executable-paths with multple-values 72 | (values (uiop:file-exists-p 73 | (merge-pathnames (format nil "bin/sbcl") 74 | (impl-path param))))) 75 | 76 | (defun impl-download (param) 77 | (let ((uri (or (impl-param-uri param) 78 | *uri-found-in-tsv* 79 | (concatenate 'string 80 | (or (impl-param-base-uri param) *base-uri*) 81 | ;;"https://github.com/roswell/sbcl_bin/releases/download/" 82 | (impl-param-version param) ;;"2.3.7" 83 | "/" 84 | (impl-param-name param) ;; "sbcl" 85 | "-" 86 | (impl-param-version param) ;;"2.3.7" 87 | "-" 88 | (impl-param-arch* param) ;;"x86-64" 89 | "-" 90 | (impl-param-os* param) ;;"linux" 91 | (if (equal (impl-param-variant* param) 92 | *vanilla*) 93 | "-" 94 | (format nil "-~A-" (impl-param-variant* param))) 95 | "binary.tar.bz2")))) 96 | (message :impl-download "Downlaad ~A/~A..." 97 | (impl-param-name param) 98 | (impl-param-version param)) 99 | (message :impl-download "URI: ~A" uri) 100 | (let ((archive (impl-archive-path param))) 101 | (message :impl-download "PATH: ~A" archive) 102 | (if (uiop:file-exists-p archive) 103 | (message :impl-download "PATH: ~A already exist. skip downloading." archive) 104 | (let ((code (simple-fetch uri archive))) 105 | (unless (zerop code) 106 | (message :impl-download "Download failed (Code=~A)" code) 107 | (return-from impl-download 1)))) 108 | param))) 109 | 110 | (defun impl-expand (param) 111 | (let ((archive (uiop:native-namestring (impl-archive-path param))) 112 | (dist-path (uiop:native-namestring 113 | (ensure-directories-exist (merge-pathnames "src/" (app-cachedir)))))) 114 | (message :impl-expand "Extracting ~A to ~A" archive dist-path) 115 | (tar 116 | (list "-xf" archive 117 | "-C" dist-path))) 118 | param) 119 | 120 | (defun find-gnumake () 121 | ;;tbd 122 | t) 123 | 124 | (defun impl-install (param) 125 | (let* ((impl-path 126 | (namestring (impl-path param))) 127 | (expand-path 128 | (namestring 129 | (merge-pathnames 130 | (concatenate 131 | 'string 132 | "src/" 133 | (impl-param-name param) 134 | "-" (impl-param-version param) 135 | "-" (impl-param-arch* param) 136 | "-" (impl-param-os* param) 137 | (or (and (equal *vanilla* (impl-param-variant* param)) 138 | "/") 139 | (format nil "-~A/" (impl-param-variant* param)))) 140 | (app-cachedir)))) 141 | (sbcl-home (namestring (merge-pathnames "lib/sbcl/" impl-path)))) 142 | (message :impl-install "Building ~A/~A(~A)..." 143 | (impl-param-name param) 144 | (impl-param-version param) 145 | (impl-param-variant* param)) 146 | (chdir expand-path) 147 | (setf (uiop:getenv "SBCL_HOME") (subseq* sbcl-home 0 -1) 148 | (uiop:getenv "INSTALL_ROOT") (subseq* impl-path 0 -1)) 149 | (unless (find-gnumake) 150 | (message :impl-install "'make' command not available.") 151 | (return-from impl-install 1)) 152 | (run-program 153 | (format nil "~A install.sh" (sh))) 154 | (message :impl-install "install Done."))) 155 | 156 | #+linux 157 | (defun impl-patchelf (param) 158 | (let* ((patchelf (which "patchelf")) 159 | (ls (which "ls")) ;; shouldn't fail on normal environment. 160 | (interpreter)) 161 | (when patchelf 162 | (setf interpreter (strip-run-cmd (format nil "patchelf --print-interpreter ~A" ls))) 163 | (loop for i in (multiple-value-list (impl-already-installedp param)) 164 | do (message :impl-patchelf "patchelf ~A ~A" 165 | (namestring i) interpreter) 166 | (strip-run-cmd (format nil "patchelf --set-interpreter ~A ~A" 167 | interpreter 168 | (namestring i))))))) 169 | 170 | (defmethod install ((param sbcl-impl-param)) 171 | (unless (impl-param-version param) 172 | (when (eql (impl-set-version-param param) 1) 173 | (return-from install 1))) 174 | (when (impl-already-installedp param) 175 | (progn 176 | (message :main-handler "~A/~A(~A) is already installed." 177 | (impl-param-name param) 178 | (impl-param-version param) 179 | (impl-param-variant* param)) 180 | (return-from install 1))) 181 | (when (eql (impl-download param) 1) 182 | (return-from install 1)) 183 | (impl-expand param) 184 | (when (eql (impl-install param) 1) 185 | (return-from install 1)) 186 | #+linux 187 | (impl-patchelf param) 188 | 0) 189 | 190 | (defmethod impl-param-class ((kind (eql :sbcl))) 191 | (declare (ignorable kind)) 192 | 'sbcl-impl-param) 193 | 194 | (defmethod impl-set-param ((param sbcl-impl-param) cmd) 195 | (declare (ignore cmd)) 196 | (message :impl-set-param "set impl-param-run" :roswell2.sbcl) 197 | (unless (impl-param-run param) 198 | (setf (impl-param-run param) :roswell2.sbcl))) 199 | 200 | (defun handler (cmd) 201 | "Handler for just evaluate options" 202 | (let ((param (make-impl-param :sbcl 203 | :cmd cmd 204 | :name "sbcl"))) 205 | (message :main-handler "args-for install ~A ~S" 206 | (impl-param-name param) 207 | (clingon:command-arguments cmd)) 208 | (message :main-handler "version: ~S" (impl-param-version param)) 209 | (uiop:quit (install param)))) 210 | -------------------------------------------------------------------------------- /lib/impl/install/sbcl/roswell2.install.sbcl.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.install.sbcl" 2 | :long-name "sbcl" 3 | :class :package-inferred-system 4 | :version "23.8.15.114" 5 | :author "SANO Masatoshi" 6 | :description "install Steel Bank Common Lisp (SBCL)" 7 | :license "MIT" 8 | :depends-on (:roswell2.install.sbcl/main)) 9 | -------------------------------------------------------------------------------- /lib/impl/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.cmd.impl/main 2 | (:use :cl 3 | :roswell-bin/util 4 | :roswell-bin/uname 5 | :roswell2/main 6 | :roswell2.cmd.run) 7 | (:nicknames :roswell2.cmd.impl) 8 | (:import-from :clingon)) 9 | 10 | (in-package :roswell2.cmd.impl/main) 11 | 12 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 13 | 14 | (defun options ()) 15 | 16 | (defun sub-commands () 17 | (sub-command-filter "roswell2.impl.")) 18 | 19 | (defun handler (cmd) 20 | "Handler for just evaluate options" 21 | (let ((args (clingon:command-arguments cmd))) 22 | (message :impl-handler "args-for impl handler ~S" args) 23 | (unless args 24 | (clingon:run cmd '("--help")))) 25 | (uiop:quit)) 26 | -------------------------------------------------------------------------------- /lib/impl/roswell2.cmd.impl.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.cmd.impl" 2 | :long-name "impl" 3 | :class :package-inferred-system 4 | :author "SANO Masatoshi" 5 | :description "maintain implementations" 6 | :license "MIT" 7 | :depends-on (:roswell2.cmd.impl/main)) 8 | -------------------------------------------------------------------------------- /lib/install/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.cmd.install/main 2 | (:use :cl 3 | :roswell-bin/util 4 | :roswell2/main 5 | :roswell2.cmd.run 6 | ) 7 | (:nicknames :roswell2.cmd.install) 8 | (:import-from :clingon)) 9 | 10 | (in-package :roswell2.cmd.install/main) 11 | 12 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 13 | 14 | (defun options () 15 | "Returns the options for the command" 16 | (list)) 17 | 18 | (defun sub-commands () 19 | ) 20 | 21 | (defun handler (cmd) 22 | "Handler for just evaluate options" 23 | (let ((args (clingon:command-arguments cmd))) 24 | (message :main-handler "args-for install handler ~S" args) 25 | (message :install-handler "forms: ~S" *forms*) 26 | (cond ((null args) 27 | ) 28 | (t 29 | ))) 30 | (uiop:quit)) 31 | -------------------------------------------------------------------------------- /lib/install/roswell2.cmd.install.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.cmd.install" 2 | :long-name "install" 3 | :class :package-inferred-system 4 | :version "23.8.15.114" 5 | :author "SANO Masatoshi" 6 | :description "Install scripts from system" 7 | :license "MIT" 8 | :depends-on (:roswell2.cmd.install/main)) 9 | -------------------------------------------------------------------------------- /lib/internal/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.cmd.internal/main 2 | (:use :cl 3 | :roswell-bin/download) 4 | (:nicknames :roswell2.cmd.internal) 5 | (:import-from :clingon)) 6 | 7 | (in-package :roswell2.cmd.internal/main) 8 | 9 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 10 | 11 | (defun options ()) 12 | 13 | (defun intern-if-it-looks-keyword (x) 14 | (if (eql #\: (ignore-errors (aref x 0))) 15 | ;; it's only care run on default sbcl so don't consider readtable-case. 16 | (intern (string-upcase x) :keyword) 17 | x)) 18 | 19 | (defun download-cmd (cmd) 20 | (let ((args (clingon:command-arguments cmd))) 21 | (apply 'simple-fetch 22 | (mapcar 'intern-if-it-looks-keyword args)))) 23 | 24 | (defun tar-cmd (cmd) 25 | (let ((args (clingon:command-arguments cmd))) 26 | (tar args))) 27 | 28 | (defun sub-commands () 29 | (list 30 | (make-instance 31 | 'roswell2/clingon.extensions::command-without-version 32 | :name "download" 33 | :description "http/https client" 34 | :handler 'download-cmd) 35 | (make-instance 36 | 'roswell2/clingon.extensions::command-without-version 37 | :name "tar" 38 | :description "extract archive" 39 | :handler 'tar-cmd))) 40 | 41 | (defun handler (cmd) 42 | "Handler for just evaluate options" 43 | (unless (clingon:command-arguments cmd) 44 | (clingon:run cmd '("--help")))) 45 | -------------------------------------------------------------------------------- /lib/internal/roswell2.cmd.internal.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.cmd.internal" 2 | :long-name "internal" 3 | :class :package-inferred-system 4 | :version "23.8.15.114" 5 | :author "SANO Masatoshi" 6 | :description "system interfaces" 7 | :license "MIT" 8 | :depends-on (:roswell2.cmd.internal/main)) 9 | -------------------------------------------------------------------------------- /lib/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2/main 2 | (:use :cl 3 | :roswell-bin/config 4 | :roswell-bin/util 5 | :roswell-bin/uname 6 | :roswell2/clingon.extensions 7 | ) 8 | (:nicknames :roswell2) 9 | (:import-from :clingon) 10 | (:import-from :cl-toml) 11 | (:export :impl-path 12 | :impl-archive-path 13 | :impl-param-variant* 14 | :impl-param-arch* 15 | :impl-param-os* 16 | :impl-param-class 17 | :make-impl-param 18 | :impl-set-run-param 19 | :impl-param 20 | :impl-param-kind 21 | :impl-param-name 22 | :impl-param-variant 23 | :impl-param-os 24 | :impl-param-arch 25 | :impl-param-base-uri 26 | :impl-param-version 27 | :impl-param-uri 28 | :impl-param-archive 29 | :impl-param-args 30 | :impl-param-native 31 | :impl-param-image 32 | :impl-param-quicklisp 33 | :impl-param-run 34 | :impl-param-forms 35 | :impl-param-wrap 36 | :impl-set-param 37 | :setup 38 | :main 39 | :command 40 | :sub-command-filter 41 | :config 42 | :config-to-string 43 | :save-config 44 | :load-config)) 45 | 46 | (in-package :roswell2/main) 47 | 48 | (defvar *command-class* 'roswell2/clingon.extensions::root-command) 49 | 50 | (defclass impl-param () 51 | ((kind 52 | :initarg :kind 53 | :initform nil 54 | :reader impl-param-kind) 55 | (name 56 | :initarg :name 57 | :initform nil 58 | :reader impl-param-name) 59 | (variant 60 | :initarg :variant 61 | :initform nil 62 | :reader impl-param-variant) 63 | (os 64 | :initarg :os 65 | :initform nil 66 | :reader impl-param-os) 67 | (arch 68 | :initarg :arch 69 | :initform nil 70 | :reader impl-param-arch) 71 | (version 72 | :initarg :version 73 | :initform nil 74 | :accessor impl-param-version) 75 | (base-uri 76 | :initarg :base-uri 77 | :initform nil 78 | :reader impl-param-base-uri) 79 | (uri 80 | :initarg :uri 81 | :initform nil 82 | :reader impl-param-uri) 83 | (archive 84 | :initarg :archive 85 | :initform nil 86 | :reader impl-param-archive) 87 | (args 88 | :initarg :args 89 | :initform nil 90 | :reader impl-param-args) 91 | (native 92 | :initarg :native 93 | :initform nil 94 | :reader impl-param-native) 95 | (quicklisp 96 | :initarg :quicklisp 97 | :initform nil 98 | :reader impl-param-quicklisp) 99 | (image 100 | :initarg :image 101 | :initform nil 102 | :reader impl-param-image) 103 | (run 104 | :initarg :run 105 | :initform nil 106 | :accessor impl-param-run) 107 | (forms 108 | :initarg :forms 109 | :initform nil 110 | :accessor impl-param-forms) 111 | (wrap 112 | :initarg :wrap 113 | :initform nil 114 | :accessor impl-param-wrap))) 115 | 116 | (defmethod impl-path ((param impl-param)) 117 | ;; "~/.cache/roswell/impl/sbcl/2.3.7/x86-64/linux/bin/" 118 | (merge-pathnames 119 | (format nil "impl/~A/~A/~A/~A/~A/" 120 | (impl-param-name param) 121 | (impl-param-version param) 122 | (impl-param-os* param) 123 | (impl-param-arch* param) 124 | (impl-param-variant* param)) 125 | (app-cachedir))) 126 | 127 | (defmethod impl-archive-path ((param impl-param)) 128 | (or (and (impl-param-archive param) 129 | (uiop:file-exists-p (impl-param-archive param))) 130 | (ensure-directories-exist 131 | (merge-pathnames (format nil "archives/~A" 132 | (concatenate 'string 133 | (impl-param-name param) ;; "sbcl" 134 | "-" 135 | (impl-param-version param) ;;"2.3.7" 136 | "-" 137 | (impl-param-arch* param) ;;"x86-64" 138 | "-" 139 | (impl-param-os* param) ;;"linux" 140 | "-" 141 | (impl-param-variant* param) 142 | "-binary.tar.bz2")) 143 | (app-cachedir))))) 144 | 145 | (defmethod impl-param-class (kind) 146 | (declare (ignorable kind)) 147 | 'impl-param) 148 | 149 | (defmethod impl-set-param ((param impl-param) cmd)) 150 | 151 | (defun make-impl-param (kind &key 152 | cmd 153 | name 154 | args 155 | version 156 | run 157 | forms 158 | (image nil image-p) 159 | (quicklisp nil quicklisp-p)) 160 | (let* ((class (impl-param-class kind)) 161 | (listp (listp cmd)) 162 | (impl (flet ((elm (id) 163 | (if listp 164 | (getf cmd id) 165 | (clingon:getopt cmd id)))) 166 | (make-instance 167 | class 168 | :kind kind 169 | :name (or name (elm :lisp)) 170 | :variant (elm :variant) 171 | :os (elm :os) 172 | :arch (elm :arch) 173 | :version (or version (elm :version)) 174 | :args args 175 | :uri (elm :uri) 176 | :base-uri(elm :base-uri) 177 | :native (elm :native) 178 | :wrap (elm :wrap) 179 | :quicklisp (if quicklisp-p 180 | quicklisp 181 | (or 182 | (and (progn 183 | (message :make-impl-param "parse quicklisp-path ~S" 184 | (elm :quicklisp-path)) 185 | (elm :quicklisp-path)) 186 | (or (uiop:directory-exists-p 187 | (elm :quicklisp-path)) 188 | (message :make-impl-param "~S is not taken as quicklisp directory" 189 | (elm :quicklisp-path)))) 190 | (elm :quicklisp))) 191 | :image (if image-p image (elm :image)) 192 | :forms forms 193 | :run run)))) 194 | (impl-set-param impl cmd) 195 | impl)) 196 | 197 | (defmethod print-object ((param impl-param) stream) 198 | (format stream "~S" 199 | (loop for c in (sb-mop:class-slots (class-of param)) 200 | for val = (slot-value param (sb-mop:slot-definition-name c)) 201 | when val 202 | append (list (first (sb-mop:slot-definition-initargs c)) val)))) 203 | 204 | (defmethod impl-param-variant* ((param impl-param)) 205 | (let* ((impl (impl-param-name param)) 206 | (variant (impl-param-variant param)) 207 | (config (load-config :where :user)) 208 | (default (ignore-errors (symbol-value (read-from-string 209 | (format nil "roswell2.install.~A:*default-variant*" impl)))))) 210 | (or (and (equal variant "") default) 211 | variant 212 | (config `(,impl "variant") config :if-does-not-exist nil) 213 | default))) 214 | 215 | (defmethod impl-param-arch* ((param impl-param)) 216 | (or (impl-param-arch param) 217 | (uname-m))) 218 | 219 | (defmethod impl-param-os* ((param impl-param)) 220 | (or (impl-param-os param) 221 | (uname-s))) 222 | 223 | (defun string-start-with-filter (str) 224 | (let ((len (length str))) 225 | (lambda (x) 226 | (and 227 | (> (length x) 228 | len) 229 | (string-equal x str :end1 len))))) 230 | 231 | (defun setup (path core-path asds-path) 232 | "" 233 | (message :setup "roswell2 setup invoked. :stage-1 ~S~%" *stage1-path*) 234 | (message :setup "path: ~A core-path: ~A asds-path: ~A" path core-path asds-path) 235 | (mapc (lambda (x) 236 | (message :setup "load-asd[~A]" x) 237 | (asdf:load-asd x)) 238 | (directory (format nil "~A*/**/*.asd" asds-path))) 239 | (setf uiop:*image-entry-point* (uiop:ensure-function "roswell2/main:main")) 240 | (loop for system-name in 241 | (remove-if-not 242 | (string-start-with-filter "roswell2.") 243 | (asdf:registered-systems)) 244 | for system = (asdf:find-system system-name) 245 | do (message :setup "load-system[~A]" system-name) 246 | (ql:quickload system-name)) 247 | (ql:quickload :roswell2/config.default) 248 | ;; tbd load system from dists. 249 | (let ((config-lisp (merge-pathnames "config.lisp" path))) 250 | (when (uiop:file-exists-p config-lisp) 251 | (message :setup "load[~A]" config-lisp) 252 | (ignore-errors (load config-lisp)))) 253 | (message :setup "dump stage2") 254 | (setf *verbose* 0) 255 | (setf *stage2-commit* 256 | (with-open-file (in (merge-pathnames "commit" (ql:where-is-system "roswell2"))) 257 | (read-line in))) 258 | (uiop:dump-image core-path :executable t)) 259 | 260 | (defvar *sub-command-filter* (make-hash-table :test 'equal)) 261 | 262 | (defun sub-command-filter (prefix) 263 | (cdr 264 | (or (gethash prefix *sub-command-filter*) 265 | (let ((sub-commands)) 266 | (loop with system-names = (remove-if-not 267 | (string-start-with-filter prefix) 268 | (asdf:registered-systems)) 269 | for system-name in system-names 270 | for command = (command system-name) 271 | do (message :sub-commands "sub command candidate for ~S ~S ~A" prefix system-name command) 272 | when (and command 273 | (not (find (clingon.command:command-name command) 274 | sub-commands 275 | :test 'equal 276 | :key 'clingon.command:command-name))) 277 | do (push command sub-commands)) 278 | (setf (gethash prefix *sub-command-filter*) (cons t sub-commands)))))) 279 | 280 | (defun sub-commands () 281 | (let ((command (sub-command-filter "roswell2.cmd."))) 282 | (message :sub-commands-main "command: ~S" command) 283 | command)) 284 | 285 | (defun options () 286 | "Returns the options for the toplevel command" 287 | (list 288 | (clingon:make-option 289 | :option-filter 290 | :description "evaluate form for stage1" 291 | :parameter "FORM" 292 | :short-name #\e 293 | :long-name "eval" 294 | :filter (lambda (x option) 295 | (declare (ignore option)) 296 | (eval (read-from-string x)) x) 297 | :key :eval) 298 | (clingon:make-option 299 | :option-filter 300 | :description "load lisp FILE for stage1" 301 | :parameter "FILE" 302 | :short-name #\l 303 | :long-name "load" 304 | :filter (lambda (x option) 305 | (declare (ignore option)) 306 | ;; tbd 307 | (print (list :load x)) x) 308 | :key :load) 309 | (clingon:make-option 310 | :counter-filter 311 | :short-name #\v 312 | :long-name "verbose" 313 | :filter (lambda (x option) 314 | (declare (ignore option)) 315 | (message :counter-filter "verbose level: ~A" x) 316 | (setf *verbose* x)) 317 | :description "be quite noisy" 318 | :key :verbose))) 319 | 320 | (defun handler (cmd) 321 | (message :main-handler "args for root handler ~S" (clingon:command-arguments cmd)) 322 | (unless (clingon:command-arguments cmd) 323 | (clingon:run cmd '("--help"))) 324 | (let ((args (clingon:command-arguments cmd))) 325 | (if (ignore-errors 326 | (uiop:file-exists-p (first args))) 327 | (clingon:run cmd`("script" "run" ,@args)))) 328 | (uiop:quit)) 329 | 330 | (defun command (system &key 331 | name) 332 | (let* ((package (or (find-package system) 333 | (find-package (string-upcase system)))) 334 | (system (asdf:find-system system)) 335 | (name (or name (asdf:system-long-name system))) 336 | (class (or (let ((it (find-symbol (string '#:*command-class*) package))) 337 | (and it 338 | (symbol-value it))) 339 | 'clingon.command:command))) 340 | (message :command "command: system:~S class:~S" system class) 341 | (when (and system 342 | name) 343 | (make-instance 344 | class 345 | :name name 346 | :description (asdf:system-description system) 347 | :version (asdf:component-version system) 348 | :authors `(,(asdf:system-author system)) 349 | :license (asdf:system-licence system) 350 | :options (funcall (find-symbol (string '#:options) package)) 351 | :handler (find-symbol (string '#:handler) package) 352 | :sub-commands (let ((it (find-symbol (string '#:sub-commands) package))) 353 | (and it (funcall it))))))) 354 | 355 | (defun main () 356 | (setf *stage2-path* (first (uiop/image:raw-command-line-arguments))) 357 | (let* ((command (command "roswell2" :name (pathname-name *stage1-path*))) 358 | (args (cdr (uiop/image:raw-command-line-arguments)))) 359 | (clingon:run command args))) 360 | 361 | (defun toml-path (where) 362 | (let ((user-directory (app-configdir)) 363 | (local-directory (uiop:getcwd))) 364 | (case where 365 | (:local (merge-pathnames ".roswell-config.toml" local-directory)) 366 | (:user (merge-pathnames "config.toml" user-directory)) 367 | (t (error "invalid where eparameter for config"))))) 368 | 369 | (defun load-config (&key 370 | (where :local) 371 | (default (make-hash-table :test 'equal))) 372 | (let ((path (toml-path where))) 373 | (values (if (uiop:file-exists-p path) 374 | (or (ignore-errors (cl-toml:parse-file path)) 375 | (message :load-config "broken ~A" path)) 376 | default) 377 | path))) 378 | 379 | (defun save-config (&key 380 | config 381 | (where :local)) 382 | (let ((path (toml-path where))) 383 | (message :save-config "save-config path:~S" path) 384 | (with-open-file (o path :direction :output 385 | :if-exists :supersede) 386 | (cl-toml:encode config o)))) 387 | 388 | (defun config-to-string (config) 389 | (with-output-to-string (o) 390 | (cl-toml:encode config o))) 391 | 392 | (defun rhash (keys hash &key (result :value) 393 | (if-does-not-exist :error) 394 | (depth 0) 395 | (debug)) 396 | "Traverse hashtable" 397 | (when debug 398 | (format t "~S~%" (list 399 | :keys keys 400 | :hash hash 401 | :result result 402 | :if-does-not-exist if-does-not-exist 403 | :depth depth))) 404 | (let ((value (gethash (first keys) hash))) 405 | (if (rest keys) 406 | (if (hash-table-p value) 407 | (rhash (rest keys) value :result result :if-does-not-exist if-does-not-exist 408 | :depth (1+ depth)) 409 | (case if-does-not-exist 410 | ((nil) nil) 411 | (:error (error "rhash no key :~S" keys)) 412 | (:create 413 | (setf value (make-hash-table :test 'equal) 414 | (gethash (first keys) hash) value) 415 | (rhash (rest keys) value :result result :if-does-not-exist if-does-not-exist 416 | :depth (1+ depth))) 417 | (t (error "invalid value for rhash if-does-not-exist")))) 418 | (case result 419 | (:value value) 420 | (:hash hash) 421 | (t result))))) 422 | 423 | (defun config (keys 424 | config 425 | &key 426 | (result :value) 427 | (if-does-not-exist :error) 428 | debug) 429 | (when (and keys 430 | (hash-table-p config)) 431 | (rhash keys config 432 | :result result 433 | :if-does-not-exist if-does-not-exist 434 | :debug debug))) 435 | 436 | (defun (setf config) (val 437 | keys 438 | config 439 | &key 440 | if-does-not-exist 441 | debug) 442 | (let ((hash (rhash keys config :result :hash :if-does-not-exist :create :debug debug))) 443 | (if val 444 | (setf (gethash (first (last keys)) hash) val) 445 | (progn 446 | (remhash (first (last keys)) hash) 447 | nil)))) 448 | 449 | #+nil 450 | (let ((config (load-config :where :user))) 451 | (setf (config '("sbcl" "variant") config) "hoge") 452 | (setf (config '("sbcl" "version") config) "hoge2") 453 | 454 | (list (config '("sbcl" "variant") config) 455 | (config '("sbcl" "version") config) 456 | (config-to-string config))) 457 | -------------------------------------------------------------------------------- /lib/roswell-bin.asd: -------------------------------------------------------------------------------- 1 | ;; just define these for package-infered system. 2 | (defsystem "roswell-bin") 3 | (defsystem "roswell-bin/archive") 4 | (defsystem "roswell-bin/build") 5 | (defsystem "roswell-bin/config") 6 | (defsystem "roswell-bin/download") 7 | (defsystem "roswell-bin/uname") 8 | (defsystem "roswell-bin/util") 9 | -------------------------------------------------------------------------------- /lib/roswell.quicklisp.extensions.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell.quicklisp.extensions" 2 | :version "23.9.20.0" 3 | :author "SANO Masatoshi" 4 | :license "MIT" 5 | :components ((:file "roswell.quicklisp.extensions"))) 6 | -------------------------------------------------------------------------------- /lib/roswell.quicklisp.extensions.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :roswell.quicklisp.extensions 2 | (:use :cl 3 | :roswell.init)) 4 | 5 | (in-package :roswell.quicklisp.extensions) 6 | 7 | (defun asd-p (file) 8 | (equal (pathname-type file) "asd")) 9 | 10 | (defun load-asd (file) 11 | (asdf:load-asd file)) 12 | 13 | (setf *load* (acons 'asd-p 'load-asd (remove 'asd-p *load* :key 'first))) 14 | 15 | (defun ros-p (file) 16 | (or (equal (pathname-type file) "ros") 17 | (null (pathname-type file)))) 18 | 19 | (defun load-ros (file) 20 | (warn "loading ros is not implemented yet ~A" file)) 21 | 22 | (setf *load* (acons 'ros-p 'load-ros (remove 'ros-p *load* :key 'first))) 23 | 24 | (defun fetch-via-roswell (url file &key (follow-redirects t) quietly (maximum-redirects 10)) 25 | "Request URL and write the body of the response to FILE." 26 | (declare (ignorable follow-redirects maximum-redirects quietly)) 27 | (let ((ret (funcall 'roswell (list "-v" "internal" "download" 28 | (ql-http::urlstring (ql-http:url url)) 29 | (namestring file)) nil))) 30 | (values (make-instance 'ql-http::header :status (if (zerop ret) 200 400)) 31 | (probe-file file)))) 32 | 33 | (dolist (x '("https" "http")) 34 | (setf ql-http:*fetch-scheme-functions* 35 | (acons x 'fetch-via-roswell 36 | (remove x ql-http:*fetch-scheme-functions* :key 'first :test 'equal)))) 37 | 38 | (pushnew :quicklisp-support-https *features*) -------------------------------------------------------------------------------- /lib/roswell2.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2" 2 | :long-name "Roswell" 3 | :class :package-inferred-system 4 | :version "24.8.11.0" 5 | :author "SANO Masatoshi" 6 | :description "a command line tool to install and manage Common Lisp implementations damn easily." 7 | :license "MIT" 8 | :depends-on (:roswell2/main)) 9 | -------------------------------------------------------------------------------- /lib/run/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.cmd.run/main 2 | (:use :cl 3 | :roswell-bin/util 4 | :roswell-bin/uname 5 | :roswell2/main 6 | :roswell2.impl.install) 7 | (:nicknames :roswell2.cmd.run) 8 | (:import-from :clingon) 9 | (:export :run 10 | :run-impl 11 | :distinguish 12 | :*forms* :impl-path)) 13 | 14 | (in-package :roswell2.cmd.run/main) 15 | 16 | (defvar *forms* nil) 17 | (defvar *command-class* 'roswell2/clingon.extensions::run-command) 18 | (defvar *category-implementation-option* "Implementation designation options") 19 | 20 | (defun filter-helper (param) 21 | (lambda (x option) 22 | (declare (ignore option)) 23 | (push (list param x) *forms*) 24 | nil)) 25 | 26 | (defun options () 27 | "Returns the options for run command" 28 | (list 29 | (clingon:make-option 30 | :string 31 | :description "designate lisp impl to run." 32 | :parameter "IMPL" 33 | :short-name #\L 34 | :long-name "lisp" 35 | :category *category-implementation-option* 36 | :key :lisp) 37 | (clingon:make-option 38 | :string 39 | :description (format nil "set arch. defualt:~A" (uname-m)) 40 | :parameter "ARCH" 41 | :long-name "arch" 42 | :category *category-implementation-option* 43 | :key :arch) 44 | (clingon:make-option 45 | :string 46 | :description "wrap implementation." 47 | :parameter "WRAP" 48 | :long-name "wrap" 49 | :category *category-implementation-option* 50 | :key :wrap) 51 | (clingon:make-option 52 | :string 53 | :description "set variant" 54 | :parameter "VARIANT" 55 | :long-name "variant" 56 | :category *category-implementation-option* 57 | :key :variant) 58 | (clingon:make-option 59 | :string 60 | :description (format nil "set os. default:~A" (uname-s)) 61 | :parameter "OS" 62 | :long-name "os" 63 | :category *category-implementation-option* 64 | :key :os) 65 | (clingon:make-option 66 | :string 67 | :description "set version" 68 | :parameter "VERSION" 69 | :long-name "version" 70 | :category *category-implementation-option* 71 | :key :version) 72 | (clingon:make-option 73 | :string 74 | :description "Run lisp with Quicklisp which home set to PATH" 75 | :parameter "PATH" 76 | :long-name "qlpath" 77 | :category "Quicklisp" 78 | :key :quicklisp-path) 79 | (clingon:make-option 80 | :boolean/true 81 | :description (format nil "Run lisp with Quicklisp home=~S" (ql:qmerge "")) 82 | :short-name #\Q 83 | :long-name "quicklisp" 84 | :category "Quicklisp" 85 | :key :quicklisp) 86 | (clingon:make-option 87 | :option-filter 88 | :description "evaluate form" 89 | :parameter "FORM" 90 | :short-name #\e 91 | :long-name "eval" 92 | :filter (filter-helper :eval) 93 | :category "Runtime options" 94 | :key :eval) 95 | (clingon:make-option 96 | :option-filter 97 | :description "load lisp FILE" 98 | :parameter "FILE" 99 | :short-name #\l 100 | :long-name "load" 101 | :filter (filter-helper :load) 102 | :category "Runtime options" 103 | :key :load) 104 | (clingon:make-option 105 | :option-filter 106 | :description "quit lisp here" 107 | :short-name #\q 108 | :long-name "quit" 109 | :filter (filter-helper :quit) 110 | :category "Runtime options" 111 | :key :quit) 112 | (clingon:make-option 113 | :option-filter 114 | :description "run repl after option processing" 115 | :long-name "repl" 116 | :filter (filter-helper :repl) 117 | :category "Runtime options" 118 | :key :repl) 119 | (clingon:make-option 120 | :option-filter 121 | :description "dump image after option processing" 122 | :parameter "FILE" 123 | :long-name "dump" 124 | :filter (filter-helper :dump) 125 | :category "Runtime options" 126 | :key :dump) 127 | (clingon:make-option 128 | :boolean/true 129 | :description "run lisp implementation without runtime option processing" 130 | :long-name "native" 131 | :category "Runtime options" 132 | :key :native) 133 | (clingon:make-option 134 | :string 135 | :description "continue from Lisp image" 136 | :parameter "IMAGE" 137 | :short-name #\m 138 | :long-name "image" 139 | :category "Runtime options" 140 | :key :image))) 141 | 142 | (defvar *config* nil) 143 | 144 | (defun sub-handler (cmd) 145 | (let* ((name (clingon.command:command-name cmd)) 146 | (run (roswell2:command :roswell2.cmd.run 147 | :name name))) 148 | (message :sub-handler "run sub-handler ~A config:~S cmd:~S forms:~S" 149 | (clingon:command-name cmd) 150 | (config `("pinned" ,name) *config*) 151 | cmd 152 | *forms*) 153 | (let* ((list (uiop:safe-read-from-string (config `("pinned" ,name) *config*))) 154 | (first (getf list :forms)) 155 | (last (getf list :args)) 156 | (mid (loop for (opt . val) in (nreverse *forms*) 157 | append `(,(format nil "--~A" (string-downcase opt)) 158 | ,@val))) 159 | (*forms* nil)) 160 | (clingon:run run `("-L" ,name 161 | ,@(when (getf list :version) 162 | (list "--version" (getf list :version))) 163 | ,@(when (getf list :variant) 164 | (list "--variant" (getf list :variant))) 165 | ,@(when (getf list :os) 166 | (list "--os" (getf list :os))) 167 | ,@(when (getf list :arch) 168 | (list "--arch" (getf list :arch))) 169 | ,@(when (getf list :image) 170 | (list "--image" (getf list :image))) 171 | ,@first 172 | ,@(or mid '("--repl")) 173 | "--" ,@last))))) 174 | 175 | (defun sub-commands () 176 | (setf *config* (load-config :where :local)) 177 | nil) 178 | 179 | (defgeneric run (kind param form &key exec &allow-other-keys) 180 | (:documentation "run")) 181 | 182 | (defgeneric distinguish (impl version) 183 | (:documentation "decide which kind of impl to be run")) 184 | 185 | (defmethod distinguish (kind version) 186 | "default method for distinguish" 187 | nil) 188 | 189 | (defun run-impl (&key param 190 | impl 191 | version 192 | args 193 | (exec 'exec) 194 | forms) 195 | (let* ((impl (impl-param-name param)) 196 | (version (impl-param-version param)) 197 | (args (impl-param-args param))) 198 | (unless version 199 | (impl-set-version-param param)) 200 | (message :run-impl "build param: ~S" param) 201 | (let* ((sym (or 202 | (distinguish (and impl (intern impl :keyword)) 203 | (and version (intern version :keyword))) 204 | (ignore-errors 205 | (let* ((path (merge-pathnames "roswell.sexp" (impl-path param))) 206 | form) 207 | (message :run-impl "read ~S" path) 208 | (unless (uiop:file-exists-p path) 209 | (message :run-impl "~S seems not exist... try install: ~S" path param) 210 | (install param)) 211 | (setf form (uiop:read-file-form path)) 212 | (message :run-impl "read roswell.sexp: ~S" form) 213 | (getf form :run)))))) 214 | (message :run-impl "just before run impl-path:~S sym:~S param:~S" 215 | (impl-path param) sym param) 216 | (values (when sym 217 | (run sym param forms :exec exec)) 218 | param)))) 219 | 220 | (defun handler (cmd) 221 | "Handler for just evaluate options" 222 | (let ((args (clingon:command-arguments cmd))) 223 | (setf *forms* (nreverse *forms*)) 224 | (message :main-handler "args-for run handler ~S forms:~S name:~S" 225 | args *forms* 226 | (clingon:command-name cmd)) 227 | (let* ((args (clingon:command-arguments cmd)) 228 | (config (load-config :where :user)) 229 | (impl (or (clingon:getopt cmd :lisp) 230 | (config `("default" "lisp") *config* :if-does-not-exist nil) 231 | (config `("default" "lisp") config :if-does-not-exist nil))) 232 | (version (or (clingon:getopt cmd :version) 233 | (and impl 234 | (or (config `(,impl "version") *config* 235 | :if-does-not-exist nil) 236 | (config `(,impl "version") config 237 | :if-does-not-exist nil)))))) 238 | (unless impl 239 | (clingon:run cmd '("--help"))) 240 | (run-impl :forms *forms* 241 | :param (make-impl-param 242 | (intern (string-upcase impl) :keyword) 243 | :cmd cmd 244 | :name impl 245 | :version version 246 | :args args) 247 | :impl impl 248 | :version version 249 | :args (clingon:command-arguments cmd))) 250 | (uiop:quit))) 251 | -------------------------------------------------------------------------------- /lib/run/roswell2.cmd.run.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.cmd.run" 2 | :long-name "run" 3 | :class :package-inferred-system 4 | :version "23.8.15.114" 5 | :author "SANO Masatoshi" 6 | :description "launch implementation." 7 | :license "MIT" 8 | :depends-on (:roswell2.cmd.run/main)) 9 | -------------------------------------------------------------------------------- /lib/run/sbcl/init.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :roswell2.run.sbcl/init 2 | (:use :cl) 3 | (:nicknames :roswell.init :ros :roswell :roswell.util) 4 | (:shadow :load :eval) 5 | (:export :main :*load* :*impl-path* :*cache-path* :*stage2-path* :roswell :ensure-asdf :quit 6 | :which :exec)) 7 | (in-package :roswell2.run.sbcl/init) 8 | 9 | (defparameter *load* `((identity . cl:load))) 10 | (defvar *impl-path* nil) 11 | (defvar *cache-path* nil) 12 | (defvar *stage2-path* nil) 13 | (defvar *run-repl* nil) 14 | (defvar *dump-file* nil) 15 | (defvar *dump-option* nil) 16 | (defvar *repl-function* nil) 17 | 18 | (defun ensure-asdf (&key (version)) 19 | (declare (ignore version)) 20 | (require :asdf)) 21 | 22 | (defun roswell (args &optional (output :string) trim) 23 | (let* ((a0 *stage2-path*) 24 | (proc (sb-ext:run-program a0 args 25 | :output :stream 26 | :error t)) 27 | (ret (if (equal output :string) 28 | (let ((input (sb-ext:process-output proc))) 29 | (with-output-to-string (o) 30 | (let ((a (make-array 512 :initial-element nil))) 31 | (loop for len = (read-sequence a input) 32 | do (write-sequence a o :end len) 33 | while (or (= len 512) 34 | (and (eql (sb-ext:process-status proc) :running) 35 | (sleep .1))))))) 36 | (loop while (and (eql (sb-ext:process-status proc) :running) 37 | (sleep .1)) 38 | finally (return-from roswell (sb-ext:process-exit-code proc)))))) 39 | (if trim 40 | (remove #\Newline (remove #\Return ret)) 41 | ret))) 42 | 43 | (defun re (&rest r) 44 | (cl:eval (read-from-string (apply 'format nil r)))) 45 | 46 | #+unix 47 | (progn ;from swank 48 | (sb-alien:define-alien-routine ("execvp" %execvp) sb-alien:int 49 | (program sb-alien:c-string) 50 | (argv (* sb-alien:c-string))) 51 | (defun execvp (program args) 52 | "Replace current executable with another one." 53 | (let ((a-args (sb-alien:make-alien sb-alien:c-string 54 | (+ 1 (length args))))) 55 | (unwind-protect 56 | (progn 57 | (loop for index from 0 by 1 58 | and item in (append args '(nil)) 59 | do (setf (sb-alien:deref a-args index) 60 | item)) 61 | (when (minusp 62 | (%execvp program a-args)) 63 | (let ((errno (sb-impl::get-errno))) 64 | (case errno 65 | (2 (error "No such file or directory: ~S" program)) 66 | (otherwise 67 | (error "execvp(3) failed. (Code=~D)" errno)))))) 68 | (sb-alien:free-alien a-args))))) 69 | 70 | (defun run-program (args &key output) 71 | (ensure-asdf) 72 | (re "(uiop:run-program ~S :output ~S :error-output :interactive)" 73 | args 74 | (or output :interactive))) 75 | 76 | (defun exec (args) 77 | "Launch executable" 78 | #+unix 79 | (execvp (first args) args) 80 | (re "(uiop:quit(run-program ~S)" args)) 81 | 82 | (defvar *strip-run-cmd-hash* (make-hash-table :test 'equal)) 83 | (defun strip-run-cmd (cmd &key cache) 84 | (ensure-asdf) 85 | (unless cache 86 | (remhash cmd *strip-run-cmd-hash*)) 87 | (if (eql (gethash cmd *strip-run-cmd-hash* t) t) 88 | (setf (gethash cmd *strip-run-cmd-hash*) 89 | (re "(uiop:run-program ~S :output '(:string :stripped t) :ignore-error-status t)" 90 | cmd)) 91 | (gethash cmd *strip-run-cmd-hash*))) 92 | 93 | (defun which (cmd) 94 | "find out command's full path." 95 | (let* ((which-cmd #-win32(format nil "command -v ~S" cmd) 96 | #+win32(format nil "cmd /c where ~S" cmd)) 97 | (result (strip-run-cmd which-cmd))) 98 | (setf result (unless (zerop (length result)) 99 | result)) 100 | result)) 101 | 102 | (defun asdf (&rest rest) 103 | (declare (ignorable rest)) 104 | (ensure-asdf)) 105 | 106 | (defun quicklisp (path-or-t &rest rest) 107 | (declare (ignorable rest)) 108 | (ensure-asdf) 109 | (unless (find :quicklisp *features*) 110 | (let* ((ql-origin (merge-pathnames "quicklisp/" *cache-path*)) 111 | (setup (merge-pathnames "setup.lisp" 112 | (if (eql t path-or-t) 113 | ql-origin 114 | path-or-t)))) 115 | (unless (eql t path-or-t) 116 | (re "(push ~S asdf:*central-registry*)" 117 | (merge-pathnames "quicklisp/" ql-origin))) 118 | (unless (probe-file (ensure-directories-exist setup)) 119 | (re "(uiop:copy-file ~S ~S)" 120 | (merge-pathnames "setup.lisp" ql-origin) 121 | setup)) 122 | (cl:load setup)))) 123 | 124 | (defun dump (file &rest rest) 125 | (declare (ignorable rest)) 126 | (setf *dump-file* file)) 127 | 128 | (defun load (file &rest rest) 129 | (let ((function (rest (find-if (lambda (x) (funcall (first x) file)) *load*)))) 130 | (apply function file rest))) 131 | 132 | (defun eval (arg &rest rest) 133 | (declare (ignorable rest)) 134 | (loop with start = 0 135 | with end = (gensym) 136 | with exp 137 | do (multiple-value-setq (exp start) 138 | (read-from-string arg nil end :start start)) 139 | until (eql exp end) 140 | do (cl:eval exp))) 141 | 142 | (defun quit (&optional (arg 0) &rest rest) 143 | (declare (ignorable rest)) 144 | (sb-ext:quit :unix-status arg)) 145 | 146 | (defun repl (&rest rest) 147 | (declare (ignorable rest)) 148 | (setf *run-repl* t)) 149 | 150 | (defun main (args) 151 | (loop with package = (find-package :roswell2.run.sbcl/init) 152 | for elt in args 153 | for sym = (intern (string (first elt)) package) 154 | do (apply sym (rest elt))) 155 | (when *dump-file* 156 | (let ((dump-file *dump-file*)) 157 | (setf *dump-file* nil) 158 | (ensure-directories-exist dump-file) 159 | (apply 'sb-ext:save-lisp-and-die dump-file *dump-option*))) 160 | (when *run-repl* 161 | (sb-ext:enable-debugger) 162 | (if *repl-function* 163 | (funcall *repl-function*) 164 | (sb-impl::toplevel-repl nil)))) 165 | 166 | (push :roswell2.init *features*) 167 | -------------------------------------------------------------------------------- /lib/run/sbcl/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.run.sbcl/main 2 | (:use :cl 3 | :roswell-bin/config 4 | :roswell-bin/util 5 | :roswell-bin/uname 6 | :roswell2/main 7 | :roswell2.cmd.run/main) 8 | (:nicknames :roswell2.run.sbcl)) 9 | (in-package :roswell2.run.sbcl/main) 10 | 11 | (defun init.lisp-path () 12 | (merge-pathnames 13 | "init.lisp" 14 | (asdf:system-source-directory 15 | (asdf:find-system :roswell2.run.sbcl)))) 16 | 17 | (defmethod run ((kind (eql :roswell2.sbcl)) 18 | param forms &key (exec 'exec)) 19 | "run sbcl installed on cachedir" 20 | (message :run "check params ~S" (impl-param-args param)) 21 | (let* ((impl-path (impl-path param)) 22 | (wrap (impl-param-wrap param)) 23 | (native (impl-param-native param)) 24 | (args (impl-param-args param)) 25 | (sbcl-home (merge-pathnames "lib/sbcl/" impl-path)) 26 | (pos (position "--" args :test 'equal)) 27 | (runtime-options (when pos (subseq args (1+ pos)))) 28 | (args (if pos (subseq args 0 pos) args)) 29 | ret 30 | help 31 | (image (impl-param-image param)) 32 | (quicklisp (impl-param-quicklisp param))) 33 | (when wrap 34 | (push wrap ret)) 35 | (push (uiop:native-namestring (merge-pathnames (format nil "bin/sbcl~A" (exeext)) impl-path)) ret) 36 | (loop while runtime-options 37 | do (push (pop runtime-options) ret)) 38 | (unless native 39 | (push "--core" ret) 40 | (push (if image 41 | image 42 | (uiop:native-namestring (merge-pathnames "sbcl.core" sbcl-home))) 43 | ret) 44 | (when (zerop *verbose*) 45 | (push "--noinform" ret)) 46 | (push "--no-sysinit" ret) 47 | (push "--no-userinit" ret) 48 | (push "--non-interactive" ret) 49 | (push "--eval" ret) 50 | (push (format nil "(progn #-roswell2.run.sbcl/init (cl:load ~S))" (init.lisp-path)) ret) 51 | (push "--eval" ret) 52 | (push (format nil "(roswell.init:main '~S)" 53 | (append `((:eval ,(format nil "(setf roswell.init:*impl-path* ~S)" impl-path)) 54 | (:eval ,(format nil "(setf roswell.init:*cache-path* ~S)" (app-cachedir))) 55 | (:eval ,(format nil "(setf roswell.init:*stage2-path* ~S)" *stage2-path*)) 56 | ,@(when quicklisp 57 | `((:quicklisp ,quicklisp)))) 58 | (or forms 59 | '((:repl))))) 60 | ret)) 61 | (setf ret (nreverse ret)) 62 | (message :run-sbcl "run-sbcl:~S" ret) 63 | (funcall exec ret))) 64 | ;;; https://thinca.hatenablog.com/entry/20100210/1265813598 65 | -------------------------------------------------------------------------------- /lib/run/sbcl/roswell2.run.sbcl.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.run.sbcl" 2 | :long-name "sbcl" 3 | :class :package-inferred-system 4 | :version "23.8.15.114" 5 | :author "SANO Masatoshi" 6 | :description "launch sbcl." 7 | :license "MIT" 8 | :depends-on (:roswell2.run.sbcl/main)) 9 | -------------------------------------------------------------------------------- /lib/script/impl/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.script.impl/main 2 | (:use :cl 3 | :roswell-bin/util 4 | :roswell-bin/config 5 | :roswell2/main 6 | :roswell2.cmd.script 7 | :roswell2.cmd.run) 8 | (:nicknames :roswell2.script.impl)) 9 | (in-package :roswell2.script.impl/main) 10 | 11 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 12 | 13 | (defun sub-commands ()) 14 | 15 | (defun options () 16 | (list 17 | (clingon:make-option 18 | :string 19 | :description "designate script name" 20 | :parameter "ALIAS" 21 | :short-name #\A 22 | :long-name "alias" 23 | :key :alias))) 24 | 25 | (defun handler (cmd) 26 | (let* ((args (clingon:command-arguments cmd)) 27 | (impl (first args)) 28 | (to (ensure-directories-exist 29 | (make-pathname 30 | :defaults (bin-dir) 31 | :name (or (clingon:getopt cmd :alias) impl) 32 | :type nil)))) 33 | (message :script-impl "script impl ~S" args) 34 | (unless (clingon:command-arguments cmd) 35 | (clingon:run cmd '("--help"))) 36 | (with-open-file (o to :direction :output :if-exists :supersede) 37 | (format o "~{~A~%~}" 38 | `("#!/bin/sh" 39 | ,(format nil "exec lisp run -L ~A --native -- \"$@\"" impl)))) 40 | (sb-posix:chmod to #o755))) 41 | -------------------------------------------------------------------------------- /lib/script/impl/roswell2.script.impl.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.script.impl" 2 | :long-name "impl" 3 | :class :package-inferred-system 4 | :author "SANO Masatoshi" 5 | :description "install script to run implementation" 6 | :license "MIT" 7 | :depends-on (:roswell2.script.impl/main)) 8 | 9 | -------------------------------------------------------------------------------- /lib/script/init/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.script.init/main 2 | (:use :cl 3 | :roswell-bin/util) 4 | 5 | (:nicknames :roswell2.script.init)) 6 | (in-package :roswell2.script.init/main) 7 | 8 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 9 | 10 | (defun sub-commands ()) 11 | 12 | (defun options ()) 13 | 14 | (defun handler (cmd) 15 | (let* ((args (clingon:command-arguments cmd)) 16 | (name (first args)) 17 | (name (namestring (make-pathname :defaults name :type nil))) 18 | params) 19 | (unless (clingon:command-arguments cmd) 20 | (clingon:run cmd '("--help"))) 21 | (map () (lambda (i) 22 | (setf name (remove i name))) 23 | "./\\") 24 | (setf params (loop for (i j) on (cdr args) by #'cddr 25 | collect (intern i :keyword) 26 | collect j)) 27 | (let* ((date (get-universal-time)) 28 | (path (make-pathname :defaults name :type "ros"))) 29 | (handler-case 30 | (unless 31 | (prog1 32 | (with-open-file (out path 33 | :direction :output 34 | :if-exists nil 35 | :if-does-not-exist :create) 36 | (when out 37 | (format out "~@{~A~%~}" 38 | "#!/bin/sh" 39 | "#|-*- mode:lisp -*-|#" 40 | "#|" 41 | "exec lisp script run -L sbcl -- -- $0 \"$@\"" "|#" 42 | "(progn ;;init forms" 43 | " (ros:ensure-asdf)" 44 | (let ((lib (getf params :|lib|))) 45 | (format nil " #+quicklisp(ql:quickload '(~A) :silent t)" 46 | (or lib ""))) 47 | " )" 48 | "" 49 | (format nil "(defpackage :ros.script.~A.~A" name date) 50 | " (:use :cl))" 51 | (format nil "(in-package :ros.script.~A.~A)" name date) 52 | "" 53 | "(defun main (&rest argv)" 54 | " (declare (ignorable argv)))" 55 | ";;; vim: set ft=lisp lisp:") 56 | (format t "~&Successfully generated: ~A~%" path) 57 | t)) 58 | (sb-posix:chmod path #o700)) 59 | (format *error-output* "~&File already exists: ~A~%" path) 60 | (uiop:quit 1)) 61 | (error (e) 62 | (format *error-output* "~&~A~%" e) 63 | (uiop:quit 1)))))) 64 | -------------------------------------------------------------------------------- /lib/script/init/roswell2.script.init.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.script.init" 2 | :long-name "init" 3 | :class :package-inferred-system 4 | :author "SANO Masatoshi" 5 | :description "Create a roswell script." 6 | :license "MIT" 7 | :depends-on (:roswell2.script.init/main)) 8 | 9 | -------------------------------------------------------------------------------- /lib/script/install/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.script.install/main 2 | (:use :cl 3 | :roswell-bin/util 4 | :roswell-bin/config 5 | :roswell2/main 6 | :roswell2.cmd.script 7 | :roswell2.cmd.run) 8 | (:nicknames :roswell2.script.install)) 9 | (in-package :roswell2.script.install/main) 10 | 11 | (defvar *build-hook* nil) 12 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 13 | 14 | (defun sub-commands ()) 15 | 16 | (defun options ()) 17 | 18 | (defun process-exec-sep (line) 19 | (loop with context = :normal 20 | with result 21 | with buf 22 | for c across line 23 | do (push c buf) 24 | do (cond ((eql context :normal) 25 | (and 26 | (or (eql c #\Space) 27 | (eql c #\Tab) 28 | (eql c #\")) 29 | (push (prog1 30 | (coerce (nreverse (cdr buf)) 'string) 31 | (setf buf nil 32 | context (cond ((find c '(#\Tab #\Space)) :space) 33 | ((find c '(#\")) :doubleq)))) 34 | result))) 35 | ((eql context :space) 36 | (and 37 | (or (eql c #\") 38 | (not (find c '(#\Tab #\Space)))) 39 | (setf buf (list (first buf)) 40 | context (cond ((find c '(#\")) :doubleq) 41 | (t :normal) 42 | )))) 43 | ((eql context :doubleq) 44 | (cond ((eql c #\") 45 | (push (coerce (nreverse buf) 'string) result) 46 | (setf buf nil 47 | context :space)) 48 | ((eql c #\\) 49 | (setf context :doubleqslash)))) 50 | ((eql context :doubleqslash) 51 | (case c 52 | (t (setf context :doubleq))))) 53 | finally (let ((str (coerce (nreverse buf) 'string))) 54 | (return (nreverse (if (zerop (length str)) 55 | result 56 | (cons str result))))))) 57 | (defun process-exec-from-ros (sep) 58 | (loop with first 59 | with second 60 | for args on (cddr sep) 61 | for a = (first args) 62 | do (cond ((find a '("-v" "--verbose" 63 | "-Q" "-A" 64 | ) :test 'equal) 65 | (push a first)) 66 | ((find a '("-L" "--lisp") :test 'equal) 67 | (push "-L" first) 68 | (pop args) 69 | (push (cond ((equal "sbcl-bin" (first args)) "sbcl") 70 | (t (first args))) first)) 71 | ((= (count #\= a) 1) 72 | (let ((pos (position #\= a))) 73 | (push (format nil "--~A" (subseq a 0 pos)) second) 74 | (push (subseq a (1+ pos)) second))) 75 | ((find a '("-m" "--image") :test 'equal) ;; ignore image 76 | (pop args))) 77 | finally (return `("exec" "lisp" "script" "run" ,@(nreverse first) "--" ,@(nreverse second) "--" "$0" "\"$@\"")))) 78 | 79 | (defun process-exec (line) 80 | (let ((sep (process-exec-sep line))) 81 | (format nil "~{~A~^ ~}" 82 | (cond ((equal (second sep) "ros") 83 | (process-exec-from-ros sep)) 84 | (t sep))))) 85 | 86 | #| 87 | (process-exec "exec ros -v dynamic-space-size=8000 -L sbcl-bin -m arrival -Q -- $0 \"\\\"$@\"") 88 | (process-exec "exec ros -Q -L sbcl-bin -- $0 \"$@\"") 89 | |# 90 | 91 | (defun register-script (to system) 92 | (message :register-script "register script file ~S system ~S" to system) 93 | (let ((file (file-namestring to)) 94 | (config (load-config :where :user))) 95 | (let ((list (coerce (config `(,system "scripts") config :if-does-not-exist nil) 'list))) 96 | (pushnew file list :test 'equal) 97 | (setf (config `(,system "scripts") config :if-does-not-exist :create) list)) 98 | (save-config :config config :where :user))) 99 | 100 | (defun copy-ros (from to) 101 | (with-open-file (in from) 102 | (with-open-file (out to :direction :output :if-exists :supersede) 103 | (format out "~A~%" (read-line in)) ;; shebang 104 | (format out "~A~%" (read-line in)) ;; mode 105 | (format out "~A ~%" (read-line in)) ;; #| 106 | (format out "~A~%" (process-exec (read-line in))) ;; exec line 107 | ;; rest of file. 108 | (loop for line = (read-line in nil nil) 109 | while line 110 | do (format out "~A~%" line))))) 111 | 112 | (defun install-file (from &key system) 113 | (let ((to (ensure-directories-exist 114 | (make-pathname 115 | :defaults (bin-dir) 116 | :name (pathname-name from) 117 | :type (unless (or (equalp (pathname-type from) "ros")) 118 | (pathname-type from))))) 119 | (ros-p (equalp (pathname-type from) "ros"))) 120 | (message :install-file "install file ~A ros-p:~A" to ros-p) 121 | (if ros-p 122 | (copy-ros from to) 123 | (uiop/stream:copy-file from to)) 124 | (when system 125 | (register-script to system)) 126 | (sb-posix:chmod to #o755) 127 | #+win32 128 | (when ros-p 129 | (copy-ros from (make-pathname :defaults to :type "ros"))))) 130 | 131 | (defun install-scripts-from-dir (dir &key system) 132 | (loop for file in (directory (merge-pathnames "roswell/*.*" dir)) 133 | do (install-file file :system system))) 134 | 135 | (defun handler (cmd) 136 | (message :script-install "script install ~S" (clingon:command-arguments cmd)) 137 | (let ((args (clingon:command-arguments cmd))) 138 | (loop with system 139 | for arg in args 140 | for script = (make-pathname :defaults arg :type "ros") 141 | do (cond ((and (pathname-name script) 142 | (uiop:file-exists-p script)) 143 | (install-file script)) 144 | ((setf system (ql-dist:find-system arg)) 145 | (ql-dist:ensure-installed system) 146 | (let ((release (ql-dist:release system))) 147 | (install-scripts-from-dir (ql-dist:base-directory release) 148 | :system (ql-dist:name system)))) 149 | ((setf system (asdf:find-system arg nil)) 150 | (let* ((asd (asdf:system-source-file system)) 151 | (dir (make-pathname :defaults asd :name nil :type nil))) 152 | (install-scripts-from-dir dir 153 | :system (asdf:component-name system)))))))) 154 | -------------------------------------------------------------------------------- /lib/script/install/roswell2.script.install.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.script.install" 2 | :long-name "install" 3 | :class :package-inferred-system 4 | :author "SANO Masatoshi" 5 | :description "Install roswell script to PATH." 6 | :license "MIT" 7 | :depends-on (:roswell2.script.install/main)) 8 | 9 | -------------------------------------------------------------------------------- /lib/script/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.cmd.script/main 2 | (:use :cl 3 | :roswell-bin/config 4 | :roswell-bin/util 5 | :roswell-bin/uname 6 | :roswell2/main 7 | :roswell2.cmd.run) 8 | (:nicknames :roswell2.cmd.script) 9 | (:import-from :clingon) 10 | (:export :bin-dir)) 11 | 12 | (in-package :roswell2.cmd.script/main) 13 | 14 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 15 | 16 | (defun bin-dir (&key native) 17 | (or 18 | (unless native 19 | (or (config `("path" "bin") (load-config :where :local) :if-does-not-exist nil) 20 | (config `("path" "bin") (load-config :where :user) :if-does-not-exist nil))) 21 | (merge-pathnames ".roswell/bin/" (user-homedir)))) 22 | 23 | (defun sub-commands () 24 | (sub-command-filter "roswell2.script.")) 25 | 26 | (defun options () 27 | ) 28 | 29 | (defun handler (cmd) 30 | "Handler for just evaluate options" 31 | (unless (clingon:command-arguments cmd) 32 | (clingon:run cmd '("--help")))) 33 | -------------------------------------------------------------------------------- /lib/script/ros-loader.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :roswell2.cmd.script/ros-loader 2 | (:use :cl) 3 | (:export :ignore-shebang)) 4 | (in-package :roswell2.cmd.script/ros-loader) 5 | 6 | (defun shebang-reader (stream sub-character infix-parameter) 7 | (declare (ignore sub-character infix-parameter)) 8 | (loop for x = (read-char stream nil nil) 9 | until (or (not x) (eq x #\newline))) 10 | (values)) 11 | 12 | (defun ignore-shebang () 13 | (set-dispatch-macro-character #\# #\! #'shebang-reader)) 14 | 15 | (push :roswell2.cmd.script *features*) 16 | -------------------------------------------------------------------------------- /lib/script/roswell2.cmd.script.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.cmd.script" 2 | :long-name "script" 3 | :class :package-inferred-system 4 | :author "SANO Masatoshi" 5 | :description "maintain ros scripts" 6 | :license "MIT" 7 | :depends-on (:roswell2.cmd.script/main)) 8 | -------------------------------------------------------------------------------- /lib/script/run/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.script.run/main 2 | (:use :cl 3 | :roswell2/main 4 | :roswell-bin/util 5 | :roswell2.cmd.script 6 | :roswell2.cmd.run) 7 | (:nicknames :roswell2.script.run)) 8 | (in-package :roswell2.script.run/main) 9 | 10 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 11 | 12 | (defun sub-commands ()) 13 | 14 | (defun options () 15 | `(,@(loop with package = (find-package :roswell2.cmd.run) 16 | for i in (funcall (find-symbol (string '#:options) package)) 17 | unless (or (member (clingon.options:option-key i) 18 | '(:quit :image :lisp :repl :dump :native :quicklisp-path :quicklisp)) 19 | (member i clingon.command:*default-options*)) 20 | collect i) 21 | ,(clingon:make-option 22 | :boolean/true 23 | :description "use quicklisp" 24 | :short-name #\Q 25 | :long-name "quicklisp" 26 | :category "Quicklisp" 27 | :key :quicklisp) 28 | ,(clingon:make-option 29 | :string 30 | :description "Take image name it will be ignored" 31 | :parameter "IMAGE" 32 | :short-name #\m 33 | :long-name "image" 34 | :category "dummy options" 35 | :key :image) 36 | ,(clingon:make-option 37 | :string 38 | :description "Take impl name it will be ignored for now." 39 | :parameter "lisp" 40 | :short-name #\L 41 | :long-name "lisp" 42 | :category "dummy options" 43 | :key :lisp) 44 | ,(clingon:make-option 45 | :counter-filter 46 | :short-name #\v 47 | :long-name "verbose" 48 | :hidden nil 49 | :filter (lambda (x option) 50 | (declare (ignore option)) 51 | (message :counter-filter "verbose level: ~A" x) 52 | (setf *verbose* x)) 53 | :description "be quite noisy" 54 | :key :verbose))) 55 | 56 | (defun parse-script (file) 57 | (let (md5sum package seq pos pos2) 58 | (with-open-file (in file) 59 | (read-line in);; read shebang 60 | (setf pos (file-position in)) 61 | (message :script-handler "ignore shebang pos:~S" pos) 62 | (with-standard-io-syntax 63 | (let ((*read-suppress* t)) 64 | (read in))) 65 | (setf pos2 (file-position in)) 66 | (message :script-handler "pos2:~S" pos2) 67 | (setf seq (make-string (- pos2 pos))) 68 | (file-position in pos) 69 | (read-sequence seq in) 70 | (message :script-handler "seq:~S" seq) 71 | (setf md5sum (format nil "~(~{~2,'0X~}~)" 72 | (coerce (sb-md5:md5sum-string seq) 'list))) 73 | (loop with eof = '#:eof 74 | for read = (read in nil eof) 75 | for is-package = (ignore-errors (string-equal "in-package" (first read))) 76 | do (when is-package 77 | (setf package (second read))) 78 | until (or (eql read eof) 79 | is-package)) 80 | (values package md5sum seq)))) 81 | 82 | (defun handler (cmd) 83 | (let* ((config (load-config :where :user)) 84 | (args (clingon:command-arguments cmd)) 85 | (impl (or (clingon:getopt cmd :lisp) 86 | "sbcl")) 87 | (version (or (clingon:getopt cmd :version) 88 | (and impl (config `(,impl "version") config :if-does-not-exist nil)))) 89 | (pos (position "--" args :test 'equal)) 90 | (native-args (when pos (cons "--" (subseq args 0 pos)))) 91 | (args (if pos 92 | (subseq args (1+ pos)) 93 | args)) 94 | (param (make-impl-param 95 | (intern (string-upcase impl) :keyword) 96 | :cmd cmd 97 | :name impl 98 | :version version 99 | :image nil 100 | :quicklisp nil))) 101 | (let ((script (uiop:file-exists-p (first args))) 102 | (impl-path (impl-path param)) 103 | (bin-dir (bin-dir :native t)) 104 | md5 package) 105 | (message :script-handler "args-for script handler ~S" args) 106 | (message :script-handler "cmd for script handler ~S" cmd) 107 | (message :script-handler "param for script handler ~S" param) 108 | (message :script-handler "fileexist: ~S" script) 109 | (unless args 110 | (clingon:run cmd '("--help"))) 111 | (multiple-value-setq (package md5) (parse-script script)) 112 | (message :script-handler "script parsed package ~S md5 ~S" package md5) 113 | (setf image 114 | (make-pathname :name (format nil "~A-~A" (pathname-name script) md5) 115 | :type "core" 116 | :defaults (translate-pathname 117 | script 118 | "/**/*.*" (merge-pathnames "core/**/*.*" impl-path))) 119 | ql (if (and (equal (pathname-directory script) 120 | (pathname-directory bin-dir)) 121 | (equal (pathname-device script) 122 | (pathname-device bin-dir))) 123 | t 124 | (namestring 125 | (merge-pathnames 126 | (format nil "~A/" (pathname-name script)) 127 | (make-pathname 128 | :name nil 129 | :type nil 130 | :defaults (translate-pathname 131 | script 132 | "/**/*.*" (merge-pathnames "quicklisp/**/*.*" impl-path))))))) 133 | (message :script-handler "image-path: ~S" image) 134 | (message :script-handler "ql-path: ~S" ql) 135 | (message :script-handler "forms: ~S" *forms*) 136 | (unless (uiop:file-exists-p image) 137 | (let (*forms* 138 | (dump-param (make-impl-param 139 | (impl-param-kind param) 140 | :args native-args 141 | :cmd cmd 142 | :name (impl-param-name param) 143 | :version (impl-param-version param) 144 | :image nil 145 | :quicklisp ql))) 146 | (push (list :eval (format nil "(with-open-file (in ~S) (read-line in) (eval (read in)))" script)) *forms*) 147 | (push (list :dump image) *forms*) 148 | (run-impl :forms *forms* :param dump-param :exec 'run-program))) 149 | (let (*forms* 150 | (run-param (make-impl-param 151 | (impl-param-kind param) 152 | :args native-args 153 | :cmd cmd 154 | :name (impl-param-name param) 155 | :version (impl-param-version param) 156 | :image (namestring image) 157 | :quicklisp ql))) 158 | (push (list :eval (format nil "(progn #-roswell2.cmd.script (cl:load ~S))" 159 | (truename (merge-pathnames 160 | "ros-loader.lisp" 161 | (asdf:system-source-directory 162 | (asdf:find-system :roswell2.cmd.script)))))) *forms*) 163 | (push (list :eval "(roswell2.cmd.script/ros-loader:ignore-shebang)") *forms*) 164 | (push (list :load script) *forms*) 165 | (push (list :eval (format nil "(apply (let ((*package* (find-package '~S))) (read-from-string \"main\")) '~S)" package (cdr args))) *forms*) 166 | (run-impl :forms (nreverse *forms*) :param run-param)))) 167 | (uiop:quit)) 168 | -------------------------------------------------------------------------------- /lib/script/run/roswell2.script.run.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.script.run" 2 | :long-name "run" 3 | :class :package-inferred-system 4 | :author "SANO Masatoshi" 5 | :description "Run roswell script." 6 | :license "MIT" 7 | :depends-on (:roswell2.script.run/main)) 8 | 9 | -------------------------------------------------------------------------------- /lib/script/uninstall/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.script.uninstall/main 2 | (:use :cl 3 | :roswell-bin/util 4 | :roswell-bin/config 5 | :roswell2/main 6 | :roswell2.cmd.script 7 | :roswell2.cmd.run) 8 | (:nicknames :roswell2.script.uninstall)) 9 | (in-package :roswell2.script.uninstall/main) 10 | 11 | (defvar *build-hook* nil) 12 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 13 | 14 | (defun sub-commands ()) 15 | 16 | (defun options ()) 17 | 18 | (defun handler (cmd) 19 | (message :script-uninstall "script uninstall ~S" (clingon:command-arguments cmd)) 20 | (let* ((args (clingon:command-arguments cmd)) 21 | (config (load-config :where :user)) 22 | (hash )) 23 | (loop for arg in args 24 | for array = (config `(,arg "scripts") config) 25 | with flag 26 | do (when array 27 | (loop for x across (copy-seq array) 28 | with result 29 | do (ignore-errors 30 | (delete-file (merge-pathnames x (bin-dir))) 31 | (push x result)) 32 | finally (setf (config `(,arg "scripts") config) 33 | (make-array (length result) :initial-contents (nreverse result)) 34 | flag t))) 35 | finally (when flag 36 | (when (= (hash-table-count (config `(,arg) config)) 1) 37 | (remhash arg config)) 38 | (save-config :config config :where :user))))) 39 | -------------------------------------------------------------------------------- /lib/script/uninstall/roswell2.script.uninstall.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.script.uninstall" 2 | :long-name "uninstall" 3 | :class :package-inferred-system 4 | :author "SANO Masatoshi" 5 | :description "Uninstall roswell script package based installation" 6 | :license "MIT" 7 | :depends-on (:roswell2.script.uninstall/main)) 8 | 9 | -------------------------------------------------------------------------------- /lib/version/main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :roswell2.cmd.version/main 2 | (:use :cl 3 | :roswell-bin/config 4 | :roswell-bin/download 5 | :roswell-bin/util 6 | :roswell-bin/uname 7 | :roswell2/main 8 | :roswell2.cmd.run) 9 | (:nicknames :roswell2.cmd.version) 10 | (:import-from :clingon)) 11 | 12 | (in-package :roswell2.cmd.version/main) 13 | 14 | (defvar *command-class* 'roswell2/clingon.extensions::command-without-version) 15 | 16 | (defun options () 17 | `( 18 | ,(clingon:make-option 19 | :string 20 | :description "Format the output" 21 | :parameter "string" 22 | :short-name #\f 23 | :long-name "format" 24 | :key :format))) 25 | 26 | (defun version-info () 27 | (let ((info (make-hash-table :test 'equal))) 28 | (setf (config (list "roswell2" "version") info) 29 | (asdf:component-version (asdf:find-system "roswell2")) 30 | (config (list "roswell2" "path") info) 31 | (namestring (ql:where-is-system "roswell2")) 32 | (config (list "roswell2" "stage1-bin") info) (namestring *stage1-path*) 33 | (config (list "roswell2" "stage1-commit") info) *stage1-commit* 34 | (config (list "roswell2" "stage2-bin") info) (namestring *stage2-path*) 35 | (config (list "roswell2" "stage2-commit") info) *stage2-commit* 36 | (config (list "sbcl" "version") info) (lisp-implementation-version) 37 | (config (list "sbcl" "variant") info) roswell2.install.sbcl:*default-variant* 38 | (config (list "quicklisp" "client") info) 39 | (handler-bind 40 | ((simple-warning #'muffle-warning)) 41 | (ql:client-version)) 42 | (config (list "quicklisp" "dist") info) (ql:dist-version "quicklisp")) 43 | (loop for elt in (sort (remove-if (lambda (x) 44 | (or (find #\/ x) 45 | (find #\. x))) 46 | (asdf:registered-systems)) #'string<) 47 | do (setf (config (list "registered-systems" elt) info) 48 | (asdf:component-version (asdf:find-system elt)))) 49 | #+nil 50 | (setf (config (list "sbcl" "features") info) 51 | (let* ((pos (position :package-local-nicknames *features* :test 'equal))) 52 | (nreverse (loop for i in (subseq *features* (1+ pos)) 53 | collect (format nil "~(~A~)" i))))) 54 | (loop for (lib sublib version) in (lib-info) 55 | do (setf (config (list lib sublib) info) version)) 56 | info)) 57 | 58 | (defun handler (cmd) 59 | "Handler for just evaluate options" 60 | (format t "~A" (config-to-string (version-info))) 61 | (uiop:quit)) 62 | -------------------------------------------------------------------------------- /lib/version/roswell2.cmd.version.asd: -------------------------------------------------------------------------------- 1 | (defsystem "roswell2.cmd.version" 2 | :long-name "version" 3 | :class :package-inferred-system 4 | :author "SANO Masatoshi" 5 | :description "show version" 6 | :license "MIT" 7 | :depends-on (:roswell2.cmd.version/main)) 8 | -------------------------------------------------------------------------------- /patch-2.2.0: -------------------------------------------------------------------------------- 1 | diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp 2 | index a8903b2..8d8f011 100644 3 | --- a/src/code/toplevel.lisp 4 | +++ b/src/code/toplevel.lisp 5 | @@ -404,7 +404,7 @@ any non-negative real number." 6 | 7 | 8 | (defvar *runtime-options* 9 | - #("--noinform" "--core" "--help" "--version" "--dynamic-space-size" 10 | + #("--noinform" "--core" "--sbcl-help" "--sbcl-version" "--dynamic-space-size" 11 | "--control-stack-size" "--tls" 12 | "--debug-environment" "--disable-ldb" "--lose-on-corruption" 13 | "--end-runtime-options" "--merge-core-pages" "--no-merge-core-pages")) 14 | diff --git a/src/runtime/Config.arm64-linux b/src/runtime/Config.arm64-linux 15 | index a073f68..7875a6a 100644 16 | --- a/src/runtime/Config.arm64-linux 17 | +++ b/src/runtime/Config.arm64-linux 18 | @@ -35,3 +35,8 @@ LINKFLAGS += -Wl,--export-dynamic 19 | # Nothing to do for after-grovel-headers. 20 | .PHONY: after-grovel-headers 21 | after-grovel-headers: 22 | + 23 | +ifdef LISP_FEATURE_SB_LINKABLE_RUNTIME 24 | + LIBSBCL = sbcl.o 25 | + USE_LIBSBCL = sbcl.o 26 | +endif 27 | diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c 28 | index 18a7759..808ed6c 100644 29 | --- a/src/runtime/runtime.c 30 | +++ b/src/runtime/runtime.c 31 | @@ -147,8 +147,8 @@ print_help() 32 | puts( 33 | "Usage: sbcl [runtime-options] [toplevel-options] [user-options]\n\ 34 | Common runtime options:\n\ 35 | - --help Print this message and exit.\n\ 36 | - --version Print version information and exit.\n\ 37 | + --sbcl-help Print this message and exit.\n\ 38 | + --sbcl-version Print version information and exit.\n\ 39 | --core Use the specified core file instead of the default.\n\ 40 | --dynamic-space-size Size of reserved dynamic space in megabytes.\n\ 41 | --control-stack-size Size of reserved control stack in megabytes.\n\ 42 | @@ -529,14 +529,14 @@ parse_argv(struct memsize_options memsize_options, 43 | core = copied_string(argv[argi]); 44 | ++argi; 45 | } 46 | - } else if (0 == strcmp(arg, "--help")) { 47 | + } else if (0 == strcmp(arg, "--sbcl-help")) { 48 | /* I think this is the (or a) usual convention: upon 49 | - * seeing "--help" we immediately print our help 50 | + * seeing "--sbcl-help" we immediately print our help 51 | * string and exit, ignoring everything else. */ 52 | print_help(); 53 | exit(0); 54 | - } else if (0 == strcmp(arg, "--version")) { 55 | - /* As in "--help" case, I think this is expected. */ 56 | + } else if (0 == strcmp(arg, "--sbcl-version")) { 57 | + /* As in "--sbcl-help" case, I think this is expected. */ 58 | print_version(); 59 | exit(0); 60 | } else if ((n_consumed = is_memsize_arg(argv, argi, argc, &merge_core_pages))) { 61 | --------------------------------------------------------------------------------