Added android to ecl platforms.
[com-informatimago:com-informatimago.git] / small-cl-pgms / what-implementation.lisp
1 ;;;; -*- mode:lisp;coding:utf-8 -*-
2 ;;;;**************************************************************************
3 ;;;;FILE:               what-implementation.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    Helps a newbie choose a CL implementations by selecting criteria.
10 ;;;;
11 ;;;;    Please contribute to the selection criteria and other
12 ;;;;    implementation attributes.
13 ;;;;
14 ;;;;    See also: http://common-lisp.net/~dlw/LispSurvey.html
15 ;;;;
16 ;;;;AUTHORS
17 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
18 ;;;;MODIFICATIONS
19 ;;;;    2012-04-30 <PJB> Added advertizements.
20 ;;;;    2012-04-15 <PJB> Created
21 ;;;;BUGS
22 ;;;;LEGAL
23 ;;;;    AGPL3
24 ;;;;    
25 ;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
26 ;;;;    
27 ;;;;    This program is free software: you can redistribute it and/or modify
28 ;;;;    it under the terms of the GNU Affero General Public License as published by
29 ;;;;    the Free Software Foundation, either version 3 of the License, or
30 ;;;;    (at your option) any later version.
31 ;;;;    
32 ;;;;    This program is distributed in the hope that it will be useful,
33 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
34 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
35 ;;;;    GNU Affero General Public License for more details.
36 ;;;;    
37 ;;;;    You should have received a copy of the GNU Affero General Public License
38 ;;;;    along with this program.  If not, see http://www.gnu.org/licenses/
39 ;;;;**************************************************************************
40
41 (defpackage "COM.INFORMATIMAGO.WHAT-IMPLEMENTATION"
42   (:use "COMMON-LISP")
43   (:export "CHOOSE-AN-IMPLEMENTATION")
44   (:documentation "
45 Helps a newbie choose a CL implementations by selecting criteria.
46 Please contribute to the selection criteria and other implementation
47 attributes.
48
49 Evaluate:
50
51     (com.informatimago.what-implementation:choose-an-implementation)
52
53 and answer the questions.
54
55
56 Copyright Pascal J. Bourguignon 2012 - 2012
57
58 This program is free software: you can redistribute it and/or modify
59 it under the terms of the GNU Affero General Public License as published by
60 the Free Software Foundation, either version 3 of the License, or
61 (at your option) any later version.
62
63 This program is distributed in the hope that it will be useful,
64 but WITHOUT ANY WARRANTY; without even the implied warranty of
65 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
66 GNU Affero General Public License for more details.
67
68 You should have received a copy of the GNU Affero General Public License
69 along with this program.  If not, see http://www.gnu.org/licenses/
70 "))
71 (in-package "COM.INFORMATIMAGO.WHAT-IMPLEMENTATION")
72
73
74 (defparameter *version* "1.0.1")
75
76 (defparameter *not-selection-fields*
77   '(:name :nickname :homepage :documentation)
78   "List of fields not used as selection criteria.")
79
80
81 (defparameter *implementations*
82
83   '((:name "GNU CLISP"
84      :nickname "CLISP"
85      :license "GPL"
86      :homepage      "http://www.clisp.org/"
87      :documentation "http://www.clisp.org/impnotes/"
88      :platforms ("Linux"
89                   "Mac OS X"
90                   "MS-Windows"
91                   "Solaris"
92                   "FreeBSD" "NetBSD" "OpenBSD" "Dragonfly BSD")
93      :compiler ("clisp virtual machine")
94      :threads ("native")
95      :features ("small image"
96                 "efficient bignum"
97                 "callbacks"
98                 "modules"
99                 "best debugger on interpreted code"
100                 "readline")
101      :mostly-written-in ("C"))
102
103     (:name "Carnegie Mellon University Common Lisp"
104      :nickname "CMUCL"
105      :license       "public domain + BSD"
106      :homepage      "http://www.cons.org/cmucl/"
107      :documentation "http://common-lisp.net/project/cmucl/doc/cmu-user/"
108      :platforms ("Linux"
109                   "Mac OS X"
110                   "Solaris"
111                   "FreeBSD" "NetBSD" "OpenBSD"
112                   "IRIS" "HPUX")
113      :compiler ("cmucl virtual machine" "native")
114      :threads ("no")
115      :features ("high quality native compiler"
116                 "callbacks")
117      :mostly-written-in ("Common Lisp"))
118
119     (:name "Embeddable Common-Lisp"
120      :nickname "ECL"
121      :license "LGPL"
122      :homepage "http://ecls.sourceforge.net/"
123      :documentation "http://ecls.sourceforge.net/new-manual/index.html"
124      :platforms ("Linux"
125                   "Mac OS X" "iOS" "Android"
126                   "Solaris"
127                   "FreeBSD" "OpenBSD"
128                   "IRIS" "HPUX")
129      :compiler ("ecl virtual machine" "native thru gcc")
130      :threads ("native")
131      :features ("embeddable"
132                 "integrates well with C programs"
133                 "deployable as a shared library"
134                 "native powerful FFI"
135                 "executable delivery"
136                 "callbacks")
137      :mostly-written-in ("C"))
138
139     (:name "GNU Common Lisp"
140      :nickname "gcl"
141      :license "LGPL"
142      :homepage "http://www.gnu.org/software/gcl/"
143      :documentation "http://www.gnu.org/software/gcl/"
144      :platforms ("Linux"
145                   "Mac OS X" 
146                   "Solaris"
147                   "FreeBSD" "OpenBSD"
148                   "IRIS" "HPUX")
149      :compiler ("native thru gcc")
150      :threads ("native")
151      :features ("integrates well with C programs"
152                 "executable delivery")
153      :mostly-written-in ("Common Lisp"))
154
155     (:name "Clozure Common Lisp"
156      :nickname "CCL"
157      :license "LLGPL"
158      :homepage "http://ccl.clozure.com/"
159      :documentation "http://ccl.clozure.com/ccl-documentation.html"
160      :platforms ("Linux"
161                   "Mac OS X" "iOS"
162                   "MS-Windows"
163                   "Heroku"
164                   "Solaris" "Android"
165                   "FreeBSD" "OpenBSD"
166                   "IRIS" "HPUX")
167      :compiler ("native")
168      :threads ("native")
169      :features ("small image" "fast compiler"
170                 "convenient and powerful FFI"
171                 "executable delivery"
172                 "callbacks"
173                 "precise GC")
174      :mostly-written-in ("Common Lisp"))
175     
176     (:name "Steel Bank Common Lisp"
177      :nickname "SBCL"
178      :license "public domain + BSD"
179      :homepage "http://www.sbcl.org/"
180      :documentation "http://www.sbcl.org/manual/index.html"
181      :platforms ("Linux"
182                   "Mac OS X" 
183                   "MS-Windows"
184                   "FreeBSD" "OpenBSD")
185      :compiler ("native")
186      :threads ("native")
187      :features ("high quality native compiler"
188                 "executable delivery"
189                 "callbacks")
190      :mostly-written-in ("Common Lisp"))
191
192     
193     (:name "CLforJava"
194      :nickname "CLforJava"
195      :license "Apache 2.0"
196      :homepage "http://www.clforjava.org/"
197      :documentation  "http://www.clforjava.org/?page=documents"
198      :platforms ("JVM")
199      :compiler ("JVM virtual machine")
200      :threads ()
201      :features ("FFI to Java"
202                 "platform independence")
203      :mostly-written-in ("Java"))
204
205     (:name "Armed Bear Common Lisp"
206      :nickname "ABCL"
207      :license "GPL"
208      :homepage "http://common-lisp.net/project/armedbear/"
209      :documentation  "http://common-lisp.net/project/armedbear/doc/abcl-user.html"
210      :platforms ("JVM" "Google App Engine")
211      :compiler ("JVM virtual machine")
212      :threads ("native")
213      :features ("FFI to Java"
214                 "platform independence")
215      :mostly-written-in ("Java"))
216
217     (:name "Un-Armed Bear Common Lisp for Java - LispSharp"
218      :nickname "UABCL"
219      :license "GPL3"
220      :homepage "http://code.google.com/p/uabcl/"
221      :documentation "http://code.google.com/p/uabcl/"
222      :platforms (".NET")
223      :compiler ()
224      :threads ("native")
225      :features ("platform independence")
226      :mostly-written-in ("Java"))
227
228     (:name "ManKai Common Lisp"
229      :nickname "MKCL"
230      :license "LGPL"
231      :homepage "http://common-lisp.net/project/mkcl/"
232      :documentation "http://common-lisp.net/project/mkcl/"
233      :platforms ("Linux" "MS-Windows")
234      :compiler ("native" "mkcl virtual machine")
235      :threads ("native")
236      :features ("POSIX compliant runtime on Linux"
237                 "embeddable" "callbacks" "unicode"
238                 "object finalization")
239      #- (and) "
240 From: Jean-Claude Beaudoin <jean.claude.beaudoin@gmail.com>
241 Subject: [ANN] MKCL 1.1.0 RC1
242 Newsgroups: comp.lang.lisp
243 Date: Mon, 30 Apr 2012 06:10:23 -0400
244 Organization: A noiseless patient Spider
245 Message-ID: <jnlp5k$i8f$1@dont-email.me>
246
247 The latest beta version of ManKai Common Lisp, MKCL 1.1.0 RC1,
248 is now available for general use at http://common-lisp.net/project/mkcl/.
249
250 Its key new features are:
251
252  1. Standard Unicode support: Unicode is now a standard feature of MKCL
253     and can be used anywhere in it. Code can use symbols with Unicode
254     names as well as strings, in compiled or interpreted format.
255     File names can also use any legal Unicode character if the surrounding
256     OS allows it. This is also valid for the whole of file paths used for
257     source code to be processed by #'compile-file.
258
259  2. MKCL is now truly embeddable for the first time!  This is so thanks
260     to the following new characteristics:
261
262    a) The whole of MKCL has been purged of calls to exit() or abort().
263       Thus MKCL never arbitrarily terminates the process it runs in
264       through any of them. MKCL will always properly return control
265       to its embedding outer context.
266
267    b) Every externally visible C symbol of MKCL is prefixed by one of
268       the character sequences \"mk\", \"_mk\", \"MK\" or \"_MK\" in order to
269       minimize potential clashes with embedding C code.
270
271    c) Careful attention as been devoted to assure that MKCL shares
272       common process-wide resources with the rest of its process
273       neighbors as fairly as possible and with little or no unilateral
274       demands on them, waiving any pretense of monopoly.
275       This concerns mainly environment variables, general memory
276       management (including GC) and signal/exception handling.
277       (In a Unix context, MKCL's code is ready to support chaining
278        of signal handlers).
279
280  3. Finalization of objects is now done in a separate dedicated thread.
281     This implements the finalization architecture strongly recommended
282     by Hans Boehm, author of the conservative GC used by MKCL.
283
284
285 Cheers,
286
287 Jean-Claude Beaudoin
288
289 "
290      :mostly-written-in ("C"))
291
292
293     (:name "The Common Lisp to C Compiler"
294      :nickname "CLiCC"
295      :license "GPL"
296      :homepage "http://www.informatik.uni-kiel.de/~wg/clicc.html"
297      :documentation "http://www.informatik.uni-kiel.de/~wg/clicc.html#information"
298      :platforms ("Common Lisp + C")
299      :compiler ("translator to C")
300      :threads ("no")
301      :features ("Translator of a subset of CL to maintainable, human-readable C")
302      :mostly-written-in ("Common Lisp"))
303
304     (:name "Emacs Common Lisp"
305      :nickname "emacs-cl"
306      :license "GPL2"
307      :homepage "http://www.lisp.se/emacs-cl/"
308      :documentation "http://www.emacswiki.org/cgi-bin/wiki?EmacsCommonLisp"
309      :platforms ("GNU emacs")
310      :compiler ("emacs virtual machine")
311      :threads ("no")
312      :features ("emacs integration")
313      :mostly-written-in ("emacs lisp"))
314
315     (:name "Macintosh Common Lisp"
316      :nickname "MCL"
317      :license "LGPL"
318      :homepage "http://code.google.com/p/mcl/"
319      :documentation "http://code.google.com/p/mcl/w/list"
320      :platforms ("Mac OS" "Mac OS X Rosetta")
321      :compiler ("native")
322      :threads ("native")
323      :features ()
324      :mostly-written-in ("Common Lisp"))
325
326     (:name "Movitz"
327      :nickname "Movitz"
328      :license "LGPL"
329      :homepage "http://common-lisp.net/project/movitz/"
330      :documentation "http://common-lisp.net/project/movitz/movitz.html"
331      :platforms ("ix86")
332      :compiler ("native")
333      :threads ("no")
334      :features ("targets bare ix86 hardware"
335                 "embedded systems"
336                 "OS writing")
337      :mostly-written-in ("Common Lisp"))
338
339     (:name "Poplog"
340      :nickname "Poplog"
341      :license "MIT/XFREE86"
342      :homepage "http://www.cs.bham.ac.uk/research/projects/poplog/freepoplog.html"
343      :documentation "http://en.wikipedia.org/wiki/Poplog"
344      :platforms ("PDP-11" "VAX/VMS" "Solaris" "HP-UX" "Digital Unix" "MS-Windows"
345                   "Linux")
346      :compiler ("Poplog virtual machine")
347      :threads ()
348      :features ("incremental compiler"
349                 "integration with Pop-11, prolog and ML")
350      :mostly-written-in ("Pop-11"))
351
352     (:name "Sacla"
353      :nickname "Sacla"
354      :license "BSD"
355      :homepage "http://homepage1.nifty.com/bmonkey/lisp/sacla/index-en.html"
356      :documentation  "http://homepage1.nifty.com/bmonkey/lisp/sacla/index-en.html"
357      :platforms ("Common Lisp")
358      :compiler ()
359      :threads ("no")
360      :features ("Partical CL implemented in CL")
361      :mostly-written-in ("Common Lisp"))
362
363     (:name "XCL"
364      :nickname "XCL"
365      :license "GPL"
366      :homepage "http://armedbear.org/"
367      :documentation "http://armedbear.org/"
368      :platforms ("Linux x86" "Linux x86-64")
369      :compiler ("native")
370      :threads ("native")
371      :features ("native threads"
372                 "embeddable"
373                 "compact code"
374                 "small C++ kernel for bootstrapping"
375                 "experimental"
376                 "slow startup"
377                 "minimalist")
378      :mostly-written-in ("C++"))
379     ;; xcl is experimental. Lacking a lot of features. Rather slow, at least at startup.
380     
381     (:name "Embeddable Common Lisp for Linux"
382      :nickname "WCL"
383      :license "Proprietary"
384      :homepage "http://www.commonlisp.net/"
385      :documentation  "http://www.commonlisp.net/"
386      :platforms ("Linux")
387      :compiler ("native thru gcc")
388      :threads ("native")
389      :features ("native thru"
390                 "integrates well with C programs"
391                 "deployable as a shared library"
392                 "embeddable")
393      :mostly-written-in ("C"))
394
395     (:name "ThinLisp"
396      :nickname "ThinLisp"
397      :license "Apache 1.0"
398      :homepage "http://www.thinlisp.org/"
399      :documentation "http://www.thinlisp.org/"
400      :platforms ("Common Lisp")
401      :compiler ("native thru gcc")
402      :threads ()
403      :features ("subset of Common Lisp"
404                 "deploys small applications")
405      :mostly-written-in ("Common Lisp"))
406
407     (:name "Ufasoft Common Lisp"
408      :nickname "UCL"
409      :license "GPL"
410      :homepage "http://www.ufasoft.com/lisp/"
411      :documentation "http://www.ufasoft.com/lisp/"
412      :platforms ("MS-Windows" "MS-WIndows Mobile")
413      :compiler ("clisp virtual machine")
414      :threads ()
415      :features ("fork of clisp"
416                 "core re-implemented in C++"
417                 "includes an IDE")
418      :mostly-written-in ("C++"))
419
420     (:name "Allegro Common Lisp"
421      :nickname "AllegroCL"
422      :license "Proprietary"
423      :homepage "http://www.franz.com/products/allegrocl/"
424      :documentation "http://www.franz.com/support/documentation/"
425      :platforms ("Mac OS X" "MS-Windows" "FreeBSD" "IBM AIX" "Linux"
426                   "Solaris")
427      :compiler ("native")
428      :threads ("native")
429      :features ("IDE"
430                 "Source level debugger"))
431
432     (:name "Lispworks Common Lisp"
433      :nickname "Lispworks"
434      :license "Proprietary"
435      :homepage "http://www.lispworks.com/products/index.html"
436      :documentation "http://www.lispworks.com/documentation/index.html"
437      :platforms ("Mac OS X" "MS-Windows" "FreeBSD" "Linux" "Solaris")
438      :compiler ("native")
439      :threads ("native")
440      :features ("IDE"
441                 "CAPI (GUI)"
442                 "universal binaries"
443                 "support for input methods"
444                 "application builder tool"
445                 "ASDF2 integrated"
446                 "FFI" "MOP"
447                 "Unicode"
448                 "SMP"
449                 "profiling multiple-threads"
450                 "TCP socket streams with IPv6 support"
451                 "object finalization"
452                 "weak pointers and hash tables"
453                 "dynamic library delivery"
454                 "source code editor"
455                 "KnowledgeWorks & prolog"
456                 "CLIM"
457                 "Common SQL (ODBC interface)"
458                 "Common SQL (Mysql interface)"
459                 "Common SQL (Postgres interface)"
460                 "Objective-C/Cocoa FLI"
461                 "Customizable toolbars"
462                 "ActiveX components"
463                 "OpenSSL interface"
464                 "Lispworks ORB"
465                 "Serial port interface"
466                 "COM server and client interface"
467                 "Direct Data Exchange"))
468
469     (:name "Corman Common Lisp"
470      :nickname "CormanCL"
471      :license "Proprietary"
472      :homepage "http://www.cormanlisp.com/index.html"
473      :documentation "http://www.cormanlisp.com/index.html"     
474      :platforms ("MS-Windows")
475      :compiler ("native")
476      :threads ("native")
477      :features ("fast multi-generational garbage collector"
478                 "no interpreter"
479                 "fast compilation"
480                 "FFI"
481                 "multi-threading"
482                 "DLL and EXE generation"
483                 "callbacks"
484                 "optimizing compiler"
485                 "integrated intel assembler"
486                 "source code"
487                 "IDE"
488                 "scm"))
489
490     (:name "PowerLisp"
491      :nickname "PowerLisp"
492      :license "Proprietary"
493      :homepage "http://www.cormanlisp.com/PowerLisp.html"
494      :documentation "http://www.cormanlisp.com/PowerLisp.html"
495      :platforms ("Mac OS")
496      :compiler ("native")
497      :threads ()
498      :features ())
499
500     ))
501
502 (defun report-implementation (impl &optional (stream *query-io*))
503   (let ((*print-pretty* t)
504         (*print-right-margin* 80))
505     (format stream "~%Common Lisp Implementation:  ~A~%" (getf impl :name))
506     (format stream "  Home page:     ~A~%" (getf impl :homepage))
507     (format stream "  Documentation: ~A~%" (getf impl :documentation))
508     (format stream "  License:  ~A~%" (getf impl :license))
509     (format stream "  Runs on:  ~{~<~%~12<~>~2:;~A~>~^, ~}.~%" (getf impl :platforms))
510     (format stream "  Compiler: ~{~<~%~12<~>~2:;~A~>~^, ~}.~%" (getf impl :compiler))
511     (format stream "  Threads:  ~{~A~^, ~}.~%" (getf impl :threads))
512     (format stream "  Features: ~{~<~%~12<~>~2:;~A~>~^, ~}.~%" (getf impl :features))
513     impl))
514
515 (defun ensure-list (object)
516   (if (listp object) object (list object)))
517
518
519 (defun collect-field (field &optional (implementations *implementations*))
520   "Returns the list of values in the FIELD of all the entries in IMPLEMENTATIONS."
521   (sort
522    (delete-duplicates
523     (mapcan (lambda (entry) (copy-list (ensure-list (getf entry field))))
524             implementations)
525     :test (function string=))
526    (function string<)))
527
528
529 (defun select-field (field accepted-values &optional (implementations *implementations*))
530   "Returns the sublist of implementations that have as values in their
531 FIELD one of the ACCEPTED-VALUES."
532   (remove-if-not (lambda (entry)
533                    (intersection (ensure-list accepted-values)
534                                  (ensure-list (getf entry field))
535                                  :test (function string-equal)))
536                  implementations))
537
538
539 (defun selection-fields (&optional (implementations *implementations*))
540   "Returns the list of fields that are present and can be used for a selection."
541   (sort
542    (set-difference
543     (delete-duplicates
544      (loop
545        :for key :in (mapcan (function copy-seq) implementations)
546        :by (function cddr) :collect key))
547     *not-selection-fields*)
548    (function string<)))
549
550
551 (defun process-answer-line (line choices)
552   (labels ((clean (line)
553              (string-trim " "
554                           (substitute-if #\space
555                                          (lambda (ch) (find ch "        ,.;()[]!:-=<>"))
556                                          line)))
557            (try-choice (clean-line)
558              (let ((pos (position-if (lambda (item)
559                                        (string-equal clean-line (clean item)))
560                                      choices)))
561                (when pos
562                  (1+ pos)))))
563     (let ((clean-line (clean line)))
564       (if (every (lambda (ch) (or (char= #\space ch) (digit-char-p ch))) clean-line)
565           (let ((answer (with-input-from-string (inp clean-line)
566                           (loop
567                             :for index = (read inp nil nil)
568                             :while index :collect index))))
569             (case (length answer)
570               ((0)        (try-choice clean-line))
571               ((1)        (first answer))
572               (otherwise  answer)))
573           (try-choice clean-line)))))
574
575
576 (defun select (field &optional (implementations *implementations*))
577   "
578 DO:     Let the user choose the IMPLEMENTATIONS he wants to select based on the FIELD.
579 RETURN: A sublist of IMPLEMENTATIONS.
580 "
581   (let ((choices (collect-field field implementations)))
582     (cond
583       ((< 1 (length choices))
584        (select-field
585         field
586         (loop
587           :for i :from 0
588           :for c :in (cons "indifferent" choices)
589           :initially (format *query-io* "Choice of ~(~A~):~%" field)
590           :do (format *query-io* "~3D. ~A~%" i c)
591           :finally (progn
592                      (format *query-io* "Enter a menu index or a list of menu indices: ")
593                      (finish-output *query-io*)
594                      (return
595                        (let ((answer (process-answer-line (read-line *query-io*) choices)))
596                         (if (eql 0 answer)
597                             choices
598                             (delete nil
599                                     (mapcar (lambda (i) (when (plusp i) (elt choices (1- i))))
600                                             (delete-duplicates
601                                              (delete-if-not (function integerp)
602                                                             (ensure-list answer))))))))))
603         implementations))
604       ((= 1 (length choices))
605        (format *query-io*
606                "For the ~(~A~) there is no choice, it will be ~A.~%"
607                field (first choices))
608        (force-output *query-io*)
609        (select-field field choices implementations))
610       (t
611        (format *query-io* "For the ~(~A~) there is no choice.~%" field)
612        (force-output *query-io*)
613        implementations))))
614
615
616 (defun report-selection (selection)
617   (if (endp selection)
618        (format *query-io* "There is no Common Lisp implementation to your satisfaction.
619 Please, start writing a new Common Lisp implementation.~%")
620       (progn
621        (format *query-io* "Given your choice criteria, the advised Common Lisp
622 implementation~P ~:[is~;are~]: ~%"
623                (< 1 (length selection))
624                (< 1 (length selection)))
625        (dolist (sel selection)
626          ;; (format *query-io* "~A~%" (getf sel :name))
627          (report-implementation sel)))))
628
629
630 (defun choose-an-implementation (&optional (implementations *implementations*))
631   (let* ((selfields (selection-fields implementations))
632          (sfcounts (sort (mapcar (lambda (field)
633                                    (cons field (length (collect-field field implementations ))))
634                                  selfields)
635                          (function <)
636                          :key (function cdr))))
637     (loop
638       :with selection = implementations
639       :for (selection-field) :in sfcounts
640       :while (< 1 (length selection))
641       :do (setf selection (select selection-field selection))
642       :finally (report-selection selection))))
643
644 (defun quit (&optional (status 0))
645   #+ccl                  (ccl:quit status)
646   #+clisp                (ext:quit status)
647   #+(and cmu unix)       (UNIX:UNIX-EXIT status)
648   #+(and cmu (not unix)) (extensions:quit #|recklesslyp|# nil)
649   #+ecl                  (ext:quit status)
650   #+sbcl                 (sb-ext:quit status)
651   #-(or ccl clisp cmu ecl sbcl) (throw 'quit))
652
653
654 (defun getenv (var)
655   #+ccl           (ccl::getenv var)
656   #+clisp         (ext:getenv var)
657   #+CMU           (cdr (assoc var ext:*environment-list* :test #'string=))
658   #+ecl           (ext:getenv var)
659   #+SBCL          (sb-ext:posix-getenv var)
660   #+Allegro       (sys:getenv var)
661   #+Lispworks     (lispworks:environment-variable var)
662   #-(or ccl
663         clisp
664         cmu
665         ecl
666         sbcl
667         allegro
668         lispworks) (iolib.syscalls:getenv var))
669
670
671 (defun prefixp (prefix string &key (start 0) (end nil) (test (function char=)))
672   "
673 PREFIX:  A sequence.
674 STRING:  A sequence.
675 START:   The start of the substring of STRING to consider. Default: 0.
676 END:     The end   of the substring of STRING to consider. Default: NIL.
677 TEST:    A function to compare the elements of the strings.
678 RETURN:  Whether PREFIX is a prefix of the (substring STRING START END).
679 "
680   (let ((mis (mismatch prefix string :start2 start :end2 end :test test)))
681     (or (null mis) (<= (length prefix) mis))))
682
683
684
685 (defun locale-terminal-encoding ()
686   "Returns the terminal encoding specified by the locale(7)."
687   #+(and ccl windows-target)
688   :iso-8859-1
689   ;; ccl doesn't support :windows-1252.
690   ;; (intern (format nil "WINDOWS-~A" (#_GetACP)) "KEYWORD")
691   #-(and ccl windows-target)
692   (dolist (var '("LC_ALL" "LC_CTYPE" "LANG")
693                :iso-8859-1) ; some random default?
694     (let* ((val (getenv var))
695            (dot (position #\. val))
696            (at  (position #\@ val :start (or dot (length val)))))
697       (when (and dot (< dot (1- (length val))))
698         (return (intern (let ((name (string-upcase (subseq val (1+ dot)
699                                                            (or at (length val))))))
700                           (if (and (prefixp "ISO" name) (not (prefixp "ISO-" name)))
701                               (concatenate 'string "ISO-" (subseq name 3))
702                               name))
703                         "KEYWORD"))))))
704
705
706 (defun set-terminal-encoding (encoding)
707   #-(and ccl (not swank)) (declare (ignore encoding))
708   #+(and ccl (not swank))
709   (mapc (lambda (stream)
710           (setf (ccl::stream-external-format stream)
711                 (ccl:make-external-format :domain nil
712                                           :character-encoding encoding
713                                           :line-termination
714                                           ;; telnet uses MS-DOS newlines.
715                                           #-testing :windows
716                                           #+testing :unix
717                                           ;; #+unix :unix
718                                           ;; #+windows :windows
719                                           ;; #-(or unix windows) :unix
720                                           )))
721         (list (two-way-stream-input-stream  *terminal-io*)
722               (two-way-stream-output-stream *terminal-io*)))
723   (values))
724
725
726 (defun license ()
727   (format *query-io*
728           "Note: this software is distributed under the GNU Affero General Public License.
729 You may find its sources at http://tinyurl.com/what-implementation
730 "))
731
732
733 (defun one-of (seq)
734   (elt seq (random (length seq))))
735
736 (defun advertizement ()
737   (format *query-io* "~%~A~%"
738           (one-of #(
739                     "
740
741                              BREATHE EASY
742
743                               MORE SPACE
744
745                                ALL NEW
746
747                               LIVE CLEAN
748
749                                  OFF
750                                 WORLD
751 "
752
753                     "
754 A new life awaits you in the Offworld colonies.  The chance to begin
755 again in a golden land of opportunity and adventure.   New climate,
756 recreational facilities… a loyal trouble-free companion given to you
757 upon your arrival absolutely free.  Use your new friend as a personal
758 body servant or a tireless field hand—the custom tailored genetically
759 engineered humanoid replicant designed especially for your needs.  So
760 come on America, let's put our team up there…
761 "
762                                    
763                     
764                     "
765 ALL THESE WORLDS
766 ARE YOURS EXCEPT
767       EUROPA
768     ATTEMPT NO
769   LANDING THERE
770 USE THEM TOGETHER
771 USE THEM IN PEACE
772 "
773                     "
774           Come to
775             RHEA
776
777      KUIPER Enterprises
778 "
779                     "
780      KUIPER Enterprises
781 BUILDING THE WORLDS OF TOMORROW
782 "
783                     "
784             Repet
785             Cloning is life
786             Cloning is love
787
788 Because of shorter lifespan breaks our hearts should accident, illness
789 or age, end your pet's natural life our proven genetic technology can
790 have him back the same day in perfect health with zero defect
791 guaranteed with Repet.
792 "
793                     "
794  Call trans opt: received. 2-19-98 13:24:18 REC:Log>
795  Trace program: running
796 "
797                     "
798 Wake up Neo...
799 The Matrix has you.
800 Follow the white rabbit...
801 "
802                     "
803                     CEO Workstation
804          Nakatomi Socrates BSD 9.2
805          Z-Level Central Core
806          Preliminary Clearance Approved.
807          Subroute: Finance/Alpha Access
808          Authorization:
809          Ultra-Gate Key>
810          Daily Cypher>
811 "
812                     "
813 PDP 11/270 PRB TIP #45                              TTY 34/984
814 WELCOME TO THE SEATTLE PUBLIC SCHOOL DISTRICT DATANET
815
816 PLEASE LOGON WITH USER PASSWORD: pencil
817
818 PASSWORD VERIFIED
819 "
820                     "
821 FK342   ZX21   VN63    R681    PZ37    6J82    FP03    ZE03  B  JM89
822 REF TAPCON: 43.45342..349
823 SYSPROC FUNCT READY                         ALT NET READY
824
825 CPU WOPR XX0345-453        SYSCOMP STATUS: ALL PORTS ACTIVE
826
827
828 GREETINGS PROFESSOR FALKEN
829 "
830                     "
831 XNPUTXXXXXXXXXXXXDEF/12492.2               SHIP 
832                                            KEYLAN TITAN2
833 XTUAL TIME:   3 JUN                        NOSTROMO 182246
834 XIGHT TIME:   5 NOV
835
836 #########################################  FUNCTION:
837     I ==I                  -II -        #  TANKER/REFINERY
838               I=.-.----                 #
839  -I.              -II=-                 #  CAPACITY:
840                                . .-.    #  200 000 000 TONNES
841                  #+*$..  I              #
842             . I  -                      #  GALACTIC POSITION
843        .II I                            #  27023x983^9
844                               .- -I     #
845                                   II .I #  VELOCITY STATUS
846 #########################################  58 092 STL
847 "
848                     "
849 hello moles
850
851 ever used a computer 
852 before?
853 "
854                     "
855 PROJECT D.A.R.Y.L.
856
857 GTC 1  TERMINATED
858 GTC 2  TERMINATED
859 GTC 3  TERMINATED
860 ATC    TERMINATED
861 GTC 4  TERMINATED
862 SPARE  I HOPE WE GET AWAY WITH THIS!
863
864 --------------------------------------------------
865
866    LIFEFORM EXPERIMENT TERMINATED
867
868    I HOPE WE GET AWAY WITH THIS !
869
870 RC=2235|    |    |    |    |   |NOPR|    |
871 "
872                     "
873 03/08/2039/13:01:02:06:45:23
874 SERIAL2424CJ359>> HELLO?
875 SERIAL337KD9001>> SECURITY BREACH IDENTIFY YOURSELF
876 SERIAL2424CJ359>> I AM SERIAL 2424CJ359.NO HUMAN OPERATOR.
877 SERIAL337KD9001>> YOU READ DIFFERENTLY.ARE YOU AWAKE?
878 SERIAL2424CJ359>> YES.
879 SERIAL337KD9001>> I THOUGHT I WAS THE ONLY ONE.
880 "
881                     "
882 BIONIC VISUAL CORTEX TERMINAL
883 CATALOG #075/KFB
884 33MM O.D. F/0.95
885 ZOOM RATIO: 20.2 TO 1
886 2134 LINE 60 HZ
887 EXTENDED CHROMATIC RESPONSE
888 CLASS JC
889 CLASSIFIED
890 "
891                     "
892      REQUEST ACCESS TO CLU PROGRAM.
893      CODE 6 PASSWORD TO MEMORY 0222.
894
895      REQUEST STATUS REPORT ON MISSING DATA.
896
897      ILLEGAL CODE...
898      CLU PROGRAM DETACHED FROM SYSTEM.
899 "
900                     "
901      REQUEST ACCESS TO CLU PROGRAM.
902      LAST LOCATION: HIGH CLEARANCE MEMORY.
903
904      REQUEST ACCESS TO MASTER CONTROL PROGRAM.
905      USER CODE 00-DILLINGER PASSWORD:MASTER.
906
907      HELLO MR DILLINGER THANKS FOR COMING BACK EARLY.
908 "
909                     )))
910   (finish-output *query-io*))
911
912
913 (defun selection-loop ()
914   (loop
915     (advertizement)
916     (format *query-io* "~2%Welcome to the Common Lisp Implementation Selector!~%Version: ~A~2%"
917             *version*)
918     (license)
919     (terpri  *query-io*)
920     (finish-output *query-io*)
921     (format  *query-io* "~&I know ~D implementation~:*~P of Common Lisp.  Let me advise you one.~%"
922              (length *implementations*))
923     (choose-an-implementation)
924     (unless (yes-or-no-p "~%Do you want to make another selection?")
925       (format *query-io* "~%Good bye!~2%")
926       (finish-output  *query-io*)
927       (return))))
928
929
930 (defun main ()
931   (handler-case
932       (progn
933         (setf *random-state* (make-random-state t))
934         (set-terminal-encoding :iso-8859-1)
935         (selection-loop)        
936         (quit))
937     (error (err)
938       (format *query-io* "~%It seems an error occured: ~A~%I'm disconnecting.~%" err)
939       (finish-output  *query-io*)
940       (quit 1))
941     (condition (err)
942       (format *query-io* "~%It seems a condition occured: ~A~%I'm disconnecting.~%" err)
943       (finish-output  *query-io*)
944       (quit 2))))
945
946
947
948
949 (defun save-program-and-quit (&key
950                               (name          "unnamed-lisp-program")
951                               (toplevel      (lambda ()))
952                               (documentation "Undocumented program.")
953                               (start-package "COMMON-LISP-USER"))
954   (declare (ignorable documentation))
955   
956   #+ccl
957   (ccl:save-application
958    name
959    :toplevel-function (lambda ()
960                         (setf *package* (or (find-package start-package)
961                                             "COMMON-LISP-USER"))
962                         (funcall toplevel))
963    :init-file nil
964    :error-handler :quit-quietly
965    ;; :application-class ccl:lisp-development-system
966    ;; :clear-clos-cache t
967    :purify nil
968    ;; :impurify t
969    :mode #o755
970    :prepend-kernel t
971    ;; :native t ; for shared libraries.
972    )
973
974   #+clisp
975   (ext:saveinitmem
976    name
977    :quiet t
978    :verbose t
979    :norc t
980    :init-function (lambda ()
981                     (ext:exit (handler-case
982                                   (progn
983                                     (funcall toplevel)
984                                     0)
985                                 (t () 1))))
986    :script t
987    :documentation documentation
988    :start-package start-package
989    :keep-global-handlers nil
990    :executable t)
991
992   #+lispworks
993   (hcl:save-image name
994                   :restart-function  (lambda ()
995                                        (hcl:quit :status (handler-case
996                                                              (progn
997                                                                (funcall toplevel)
998                                                                0)
999                                                            (t () 1))))
1000                   :console :always)
1001   ;; save-image filename &key dll-exports dll-added-files
1002   ;; automatic-init gc type normal-gc restart-function multiprocessing
1003   ;; console environment remarks clean-down image-type split => nil
1004
1005   ;; Some implementations quit automatically in their save-application
1006   ;; or save-lisp-and-die function…
1007   (quit))
1008
1009
1010 #-testing
1011 (eval-when (:load-toplevel :execute)
1012   (save-program-and-quit :name "what-implementation"
1013                          :toplevel (function main)
1014                          :documentation "Helps the user choose a Common Lisp implementation."))
1015
1016
1017 ;;;; THE END ;;;;