add lispworks

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 \
 	\

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)))

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)

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

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<argc;++i)
+    ret=conss(q(argv[i]),ret);
+
+  ret=nreverse(ret);
+  print_list(ret);
+  return stringlist_array(ret);
+}

src/cmd-run.c

@@ -20,6 +20,7 @@ struct run_impl_t impls_to_run[]={
   {"acl",&cmd_run_acl},
   {"alisp",&cmd_run_acl},
   {"allegro",&cmd_run_acl},
+  {"lispworks",&cmd_run_lispworks},
 };
 
 struct proc_opt run;

src/cmd-run.h

@@ -22,6 +22,7 @@ extern char** cmd_run_ecl(int argc,char** argv,struct sub_command* cmd);
 extern char** cmd_run_abcl(int argc,char** argv,struct sub_command* cmd);
 extern char** cmd_run_cmu(int argc,char** argv,struct sub_command* cmd);
 extern char** cmd_run_acl(int argc,char** argv,struct sub_command* cmd);
+extern char** cmd_run_lispworks(int argc,char** argv,struct sub_command* cmd);
 extern LVal register_runtime_options();
 int setup(char* target,char* env,char* impl);
 #define SETUP_SYSTEM(sys,msg) {\