From f0592d076b486db4a5a92d2f2a474ff04260d5d4 Mon Sep 17 00:00:00 2001 From: cxxxr Date: Wed, 21 Mar 2018 22:21:55 +0900 Subject: [PATCH] add lispworks --- Makefile.am | 2 +- lisp/install-lispworks.lisp | 95 +++++++++++++++++++++++++++++++++++++ lisp/util.lisp | 2 + src/Makefile.am | 2 +- src/cmd-run-lispworks.c | 38 +++++++++++++++ src/cmd-run.c | 1 + src/cmd-run.h | 1 + 7 files changed, 139 insertions(+), 2 deletions(-) create mode 100644 lisp/install-lispworks.lisp create mode 100644 src/cmd-run-lispworks.c diff --git a/Makefile.am b/Makefile.am index 000cca2..53ab3c8 100644 --- a/Makefile.am +++ b/Makefile.am @@ -65,7 +65,7 @@ LISPS = helper.el \ install-ccl-bin.lisp install-clasp.lisp install-clisp.lisp \ install-cmu-bin.lisp install-ecl.lisp install-quicklisp.lisp \ install-sbcl-bin.lisp install-sbcl.lisp install-slime.lisp \ - install-sly.lisp \ + install-sly.lisp install-lispworks.lisp \ install+externals-clasp.lisp install+ffcall.lisp \ install+msys2.lisp install+sigsegv.lisp install-asdf.lisp \ \ diff --git a/lisp/install-lispworks.lisp b/lisp/install-lispworks.lisp new file mode 100644 index 0000000..8c78ec0 --- /dev/null +++ b/lisp/install-lispworks.lisp @@ -0,0 +1,95 @@ +(defpackage :roswell.install.lispworks + (:use :cl :roswell.util)) +(in-package :roswell.install.lispworks) + +(defparameter *code* +"(in-package \"CL-USER\") +(load-all-patches) + +(defun main () + (let ((args (rest sys:*line-arguments-list*))) + (loop :until (null args) + :for arg := (pop args) + :do (cond ((string= arg \"--eval\") + (eval (read-from-string (pop args)))))))) + +(pushnew '(\"Main\" (:priority 60000000 :restart-action :continue) main) + mp:*initial-processes*) + +(save-image ~S + :console t + :multiprocessing t + :environment nil)") + +(defun get-option (argv option) + (second (member option argv :test #'string=))) + +(defun touch (file) + (with-open-file (stream file :direction :output :if-exists :supersede :if-does-not-exist :create)) + file) + +(defun guess-version (lw-tar) + (let ((list (uiop:split-string (pathname-name lw-tar) :separator "-."))) + (let ((major (digit-char-p (char (first list) 2))) + (minor (digit-char-p (char (first list) 3))) + (arch (second list)) + (os (third list))) + (values major minor arch os)))) + +(defun build-lw-console (prefix lw-program) + (let ((lw-console (merge-pathnames "lw-console" prefix))) + (uiop:with-temporary-file (:stream stream :pathname lw-file) + (write-string (format nil *code* lw-console) stream) + :close-stream + (uiop:run-program (list lw-program "-build" (princ-to-string lw-file)))))) + +(defun install-1 (prefix lw-tar lwdoc-tar) + (ensure-directories-exist prefix) + (setf prefix (probe-file prefix)) + (uiop:run-program (format nil "tar -zxf '~A' -C '~A'" lw-tar prefix)) + (when lwdoc-tar (uiop:run-program (format nil "tar -zxf '~A' -C '~A'" lwdoc-tar prefix))) + (let ((lwlicfile (merge-pathnames "lib/7-1-0-0/config/lwlicense" prefix))) + (touch lwlicfile) + (sb-posix:chmod (probe-file lwlicfile) #o666))) + +(defun install (argv) + (let* ((argv (getf argv :argv)) + (lw-tar (get-option argv "--lw-tar")) + (lwdoc-tar (get-option argv "--lwdoc-tar")) + (serial-number (get-option argv "--lwlicenseserial")) + (key (get-option argv "--lwlicensekey")) + (prefix (merge-pathnames (make-pathname + :directory (list :relative "impls" (uname-m) (uname) "LispWorks")) + (homedir)))) + (multiple-value-bind (major minor arch os) + (guess-version lw-tar) + (install-1 prefix lw-tar lwdoc-tar) + (let ((lw-program (merge-pathnames (format nil "lispworks-~D-~D-0-~A-~A" + major minor arch os) + prefix))) + (uiop:run-program (list lw-program + "--lwlicenseserial" serial-number + "--lwlicensekey" key)) + (build-lw-console prefix lw-program))))) + +(defun help (argv) + (format t "lispworks install options~%") + (flet ((fmt (param default more) + (format t "--~A ~A~%~5T~A~%" + param + (or (and (not (null default)) + (not (eql default t)) + default) + "") + more))) + (fmt "lw-tar" nil "") + (fmt "lwdoc-tar" nil "") + (fmt "--lwlicenseserial" nil "") + (fmt "--lwlicensekey" nil "")) + (cons t argv)) + +(defun lispworks (type) + (case type + (:help '(help)) + (:install '(install)) + (:list))) diff --git a/lisp/util.lisp b/lisp/util.lisp index b8132d1..5e7fe41 100644 --- a/lisp/util.lisp +++ b/lisp/util.lisp @@ -29,6 +29,7 @@ #+cmucl(let ((f (ignore-errors (symbol-function (read-from-string "unix:unix-setenv"))))) (when f (funcall f name value 1))) #+ecl(ext:setenv name value) + #+lispworks (hcl:setenv name name value) value) (defun unsetenv (name) @@ -38,6 +39,7 @@ #+clisp(system::setenv name nil) #+cmucl(let ((f (ignore-errors (symbol-function (read-from-string "unix:unix-unsetenv"))))) (when f (funcall f name))) + #+lispworks(hcl:setenv name nil) nil) (defun read-call (func &rest params) diff --git a/src/Makefile.am b/src/Makefile.am index 534e4a2..a7536e3 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -14,7 +14,7 @@ ros_SOURCES = ros.c opt.c download.c download_windows.c archive.c archive_window register-commands.c html.c html-sbcl-bin.c \ $(ros_utils) \ cmd-internal.c cmd-script.c \ - cmd-run.c cmd-run-sbcl.c cmd-run-ccl.c cmd-run-clasp.c cmd-run-clisp.c cmd-run-ecl.c cmd-run-abcl.c cmd-run-cmu.c cmd-run-acl.c \ + cmd-run.c cmd-run-sbcl.c cmd-run-ccl.c cmd-run-clasp.c cmd-run-clisp.c cmd-run-ecl.c cmd-run-abcl.c cmd-run-cmu.c cmd-run-acl.c cmd-run-lispworks.c \ cmd-install.c install-sbcl-bin.c install-sbcl-bin_windows.c if WITH_WIN_ICON diff --git a/src/cmd-run-lispworks.c b/src/cmd-run-lispworks.c new file mode 100644 index 0000000..b08dac8 --- /dev/null +++ b/src/cmd-run-lispworks.c @@ -0,0 +1,38 @@ +#include "opt.h" + +char** cmd_run_lispworks(int argc,char** argv,struct sub_command* cmd) { + char* home=configdir(); + char* arch=uname_m(); + char* os=uname(); + + char* help=get_opt("help",0); + char* script=get_opt("script",0); + char* image=get_opt("image",0); + char* program=get_opt("program",0); + char* lw_version=get_opt("version",0); + + LVal ret=0; + ret=conss(cat(home,"impls",SLASH,arch,SLASH,os,SLASH,"LispWorks",SLASH,"lw-console",NULL), ret); + + if(lw_version) { + ret=conss(q("--eval"),ret); + ret=conss(q("(progn (format t \"~A ~A~%\" (lisp-implementation-type) (lisp-implementation-version))(lw:quit))"),ret); + } + + ret=conss(q("--eval"),ret); + ret=conss(s_cat(q("(progn #-ros.init(cl:load \""),s_escape_string(lispdir()),q("init.lisp"),q("\"))"),NULL),ret); + if(program || script) { + ret=conss(q("--eval"),ret); + ret=conss(s_cat(q("(ros:run '("),q(program?program:""), + script?cat("(:script ",script,")","(:quit ())",NULL):q(""), + q("))"),NULL),ret); + } + + int i; + for(;i