#!/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
ViewGit