#!/bin/bash
# -*- coding:utf-8 -*-
#*****************************************************************************
#FILE: clall
#LANGUAGE: bash
#SYSTEM: POSIX
#USER-INTERFACE: NONE
#DESCRIPTION
#
# Executes a form in various Common Lisp implementations.
#
# Note: we can run in cygwin, calling cygwin CL implementations
# (ie. clisp), or calling MS-Windows CL implementations. But for
# MS-Windows CL implementations, we need to convert the unix paths
# into MS-Windows path. For convenience, MS-Windows CL
# implementations are called thru scripts in /usr/local/bin whose
# name starts with "win".
#
#AUTHORS
# <PJB> Pascal Bourguignon <pjb@informatimago.com>
#MODIFICATIONS
# 2010-11-01 <PJB> Improved.
# Added the -r option to just print the results.
# Added abcl.
# 2007-07-05 <PJB> Added this header.
#BUGS
# cmucl and sbcl don't seem to signal an error on program errors in defun
# (defun f () (let z 42) (print z))
#LEGAL
# GPL
#
# Copyright Pascal Bourguignon 2007 - 2010
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version
# 2 of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be
# useful, but WITHOUT ANY WARRANTY; without even the implied
# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
# PURPOSE. See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public
# License along with this program; if not, write to the Free
# Software Foundation, Inc., 59 Temple Place, Suite 330,
# Boston, MA 02111-1307 USA
#*****************************************************************************
#export PATH=/bin:/usr/bin
trap 'printf "\ninterrupted\n";exit 1' INT
epilog=/tmp/clall-$$.epilog
script=/tmp/clall-$$.lisp
output=/tmp/clall-$$.output
winscript=/tmp/clall-$$-win.lisp
errors=()
usage(){
pname="$(basename $0)"
printf "%s usage:\n\n %s [-f|--full | -r|--result] expression...\n\n" "$pname" "$pname"
printf " -w|--which shows the pathnames of the available implementations. \n"
printf " -f|--full shows detailed results.\n"
printf " -s|--short which is the default, shows output and results \n"
printf " if no error is detected, or full if there's an error.\n"
printf " -r|--result shows only the results, on a single line, for each implementation.\n"
printf " -d|--debug keep the script and output for debugging.\n"
printf " -- userargs... passes further user arguments.\n"
printf "\n\n"
}
cygwin="C:\\\\cygwin" # the root of cygwin, where it is installed.
command=short
which=0
keepscript=0
user_args=()
sexps=()
while [ $# -ge 1 ] ; do
case "$1" in
-w|--which) which=1 ; shift ;;
-f|--full) command=full ; shift ;;
-s|--short) command=short ; shift ;;
-r|--result) command=result ; shift ;;
-d|--debug) keepscript=1 ; shift ;;
--) shift ; user_args=(-- "$@") ; shift "$#" ;;
-*) printf "%s error: Unknown option: %s\n" "$0" "$1" ; usage ; exit 1 ;;
*) sexps[${#sexps[@]}]="$1" ; shift ;;
esac
done
if [ $keepscript -eq 0 ] ; then
trap 'rm "$epilog" "$script" "$winscript" "$output" "${errors[@]}"' 0
fi
clall_lisp='
;; CMU uses ALIEN in CL-USER, and there is a locked ALIEN:SHORT.
#-mocl
(defpackage "COM.INFORMATIMAGO.CLALL"
(:use #-gcl "COMMON-LISP" #+gcl "LISP")
(:nicknames "CLALL"))
#-mocl
(in-package "COM.INFORMATIMAGO.CLALL")
(setf *print-readably* nil)
#+gcl (defmacro ignore-errors (&body body) `(progn ,@body))
(defvar *double-line* "========================================================================")
(defvar *simple-line* "------------------------------------------------------------------------")
(defun read-eval (input)
"Read and evaluate the input.
Return: input
nil or read error
expression
nil or eval error
list of values
*standard-output* string
*error-output* string
*trace-output* string
"
(multiple-value-bind (vals condi)
(ignore-errors (multiple-value-list (read-from-string input)))
(if condi
(values input condi nil nil nil nil nil)
(destructuring-bind (expression remains-to-read) vals
(unless (= (length input) remains-to-read)
(warn "~A byte~:*~P unread." (- (length input) remains-to-read )))
(let (trace error output)
(setf output (with-output-to-string (*standard-output*)
(setf error (with-output-to-string (*error-output*)
(setf trace (with-output-to-string (*trace-output*)
(multiple-value-setq (vals condi)
#-(or abcl ecl gcl) (ignore-errors (multiple-value-list (eval expression)))
#+(or abcl ecl gcl) (handler-case (multiple-value-list (eval expression))
(error (err) (values nil err))
(condition (err) (values nil err))))))))))
(values input nil expression condi vals output error trace))))))
(defun report-only-result (report input read-error expression eval-error vals output error trace)
(declare (ignore input expression output error trace))
(cond
(read-error
(format report "~30A ~A~%" (lisp-implementation-type)
(substitute #\space #\newline (princ-to-string read-error))))
(eval-error
(format report "~30A ~A~%" (lisp-implementation-type)
(substitute #\space #\newline (princ-to-string eval-error))))
((null vals)
(format report "~30A --> No value.~%" (lisp-implementation-type)))
(t
(format report "~30A --> ~{~S~^, ~}~%" (lisp-implementation-type) vals))))
(defun report-full-result (report input read-error expression eval-error vals output error trace)
(format report "~&~A~%" *double-line*)
(format report "Implementation: ~A ~A~% on ~A ~A~% on ~A ~A (~A)~%"
(lisp-implementation-type)
(lisp-implementation-version)
(software-type)
(software-version)
(machine-type)
(machine-version)
(machine-instance))
(format report "~%Reading of: ~S~%" input)
(if (null read-error)
(format report "signaled no error~%")
(format report "signaled the following error:~% ~S~% ~:*~A~%" read-error))
(format report "~%Evaluation of: ~S~%" expression)
(if (null eval-error)
(format report "signaled no error~%")
(format report "signaled the following error:~% ~S~% ~:*~A~%" eval-error))
(flet ((report (name data)
(if (or (null data) (string= "" data))
(format report "wrote nothing on ~A~%" name)
(progn
(format report "wrote the following ~A (lines excluded):" name)
(format report "~&~A~%" *simple-line*)
(format report "~A" data)
(format report "~&~A~%" *simple-line*)))))
(report (quote *error-output*) error)
(report (quote *trace-output*) trace)
(report (quote *standard-output*) output))
(if (null vals)
(format report "returned no value~%")
(format report "returned the following value~P:~%--> ~{~S~^ ;~% ~}~2%" (length vals) vals)))
(defun report-short-result (report input read-error expression eval-error vals output error trace)
(format report "~2%~A:" (lisp-implementation-type))
(if (or read-error eval-error)
(report-full-result report input read-error expression eval-error vals output error trace)
(progn
(unless (or (null output) (string= "" output))
(format report "~A" output))
(when vals
(format report "~&--> ~{~S~^, ~}~%" vals)))))
(defmacro result (output &body expressions)
`(with-open-file (report ,output
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
,@(mapcar (lambda (input)
`(multiple-value-call (function report-only-result) report (read-eval ,input)))
expressions)
(values)))
(defmacro full (output &body expressions)
`(with-open-file (report ,output
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
,@(mapcar (lambda (input)
`(multiple-value-call (function report-full-result) report (read-eval ,input)))
expressions)
(values)))
(defmacro short (output &body expressions)
`(with-open-file (report ,output
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
,@(mapcar (lambda (input)
`(multiple-value-call (function report-short-result) report (read-eval ,input)))
expressions)
(values)))
'
# quote is used to quote unix pathnames and sexps.
quote(){
for arg ; do
local slash=${arg//\\/\\\\}
local quote=\"${slash//\"/\\\"}\"
printf "%s " ${quote}
done
printf "\n"
}
# winquote is used to transform unix pathnames into MS-Windows pathnames on cygwin.
winquote(){
local slash
local quote
for arg ; do
case "$arg" in
/*)
slash="${arg//\//\\\\}"
;;
*)
arg="$(pwd -P)/$arg"
slash="${arg//\//\\\\}"
;;
esac
quote=${cygwin}${slash//\"/\\\"}
printf "%s " "${quote}"
done
printf "\n"
}
( echo "$clall_lisp"
if [ ${#sexps[@]} -gt 0 ] ; then
echo "($command $(quote "$output")"
for sexp in "${sexps[@]}" ; do echo "$(quote "$sexp")" ; done
echo ")"
fi ) >> "$script"
( echo "$clall_lisp"
if [ ${#sexps[@]} -gt 0 ] ; then
echo "($command \"$(winquote "$output")\""
for sexp in "${sexps[@]}" ; do echo "$(quote "$sexp")" ; done
echo ")"
fi ) >> "$winscript"
echo > "$epilog"
echo "#+abcl (extensions:quit)" >> "$epilog"
# #+allegro (excl:exit) ;; This dumps an "; Exiting" message...
echo "#+ccl (ccl:quit)" >> "$epilog"
echo "#+clisp (ext:quit)" >> "$epilog"
echo "#+cmu (ext:quit)" >> "$epilog"
echo "#+ecl (si:quit)" >> "$epilog"
echo "#+gcl (lisp:quit)" >> "$epilog"
echo "#+sbcl (sb-ext:quit)" >> "$epilog"
echo "#+lispworks (ext:quit)" >> "$epilog"
echo "#+mocl (rt:quit)" >> "$epilog"
cat "$epilog" >> "$script"
cat "$epilog" >> "$winscript"
function runcl(){
local implementation="$1" ; shift
local error="/tmp/clall-$$-${implementation}.error"
if type -p "$implementation" >/dev/null ; then
if [ $which -ne 0 ] ; then
type -p "$implementation"
fi
touch "$output"
errors[${#errors[@]}]="$error"
"$implementation" "$@" "${user_args[@]}" > "$error" 2>&1 && cat "$output"
fi
}
printf '\n'
abcl_cli_init=(--eval '(setq *load-verbose* nil)')
lisp_cli_init=( -eval '(setq *load-verbose* nil)')
sbcl_cli_init=(--eval '(setf sb-impl::*default-external-format* :utf-8)')
runcl abcl --batch --noinform --noinit "${abcl_cli_init[@]}" --load "$script"
runcl alisp -batch -qq -L "$script" -kill
runcl ccl --batch --no-init --load "$script"
runcl clisp -ansi -q -norc "$script"
# debian calls cmucl cmucl instead of lisp.
runcl cmucl -noinit "${lisp_cli_init[@]}" -load "$script"
runcl lisp -noinit "${lisp_cli_init[@]}" -load "$script"
runcl ecl -norc -load "$script"
# we can't run gcl, because it can't handle errors. (ignore-errors, handler-case).
# runcl gcl -batch -load "$script"
# runcl mocl repl --verbose --android /tmp/ < "$script"
runcl sbcl --noinform --no-userinit "${sbcl_cli_init[@]}" --load "$script"
runcl winccl --batch --no-init --load $(winquote $winscript)
runcl winsbcl --noinform --no-userinit --load $(winquote $winscript)
# runcl maclispw -tty -init - -eval '(setq *load-verbose* nil)' -load "$script"
if [ "$command" != "result" -a ${#sexps[@]} -gt 0 ] ; then
printf '\n'
printf '========================================================================\n'
fi
printf '\n'
if [ $keepscript -ne 0 ] ; then
printf 'script = %s\n' "$script"
printf 'winscript = %s\n' "$winscript"
printf 'output = %s\n' "$output"
fi
exit 0
# clall \
# '(let ((*read-suppress* nil)) (read-from-string "#.(values) 42"))' \
# '(let ((*read-suppress* t )) (read-from-string "#.(values) 42"))'
# abcl options:
# --noinit
# --nosystem
# --noinform
# --batch
# --eval $EXPRESSION
# --load | --load-system-file $FILE