[Gcl-devel] CLC post pathnames ...

[Dennis Decker Jensen]

Hi Michael

I noticed you started looking at pathnames &c.

When I tried to get CLC working with GCL
I made the little Bourne shell script
necessary to get GCL working with CLC,
or at least a first shot at it.

In case you or others get around to play
around with CLC I put it out here free
to use.  It might come in handy in case
you haven't made a script already.

--
gcl.sh
=====
#!/bin/sh
 
progname=$(basename $0)
gcl_clc=/usr/lib/common-lisp/gcl/common-lisp-controller

#if test ! -f $gcl_clc/common-lisp-controller.o; then
if test ! -f 
/usr/share/common-lisp/source/common-lisp-controller/common-lisp-controller.lisp;
 then
        echo "Cannot find common-lisp-controller." 1>&2
        echo "Please report this as a bug." 1>&2
        exit 1
fi

gcl=$(command -v ${progname%.sh})
gcl_system_dir=$($gcl -batch -eval '(princ si:*system-directory*)')
image=$gcl_system_dir/saved_ansi_gcl
pristine_image=$gcl_system_dir/saved_ansi_gcl_pristine
new_image=$gcl_system_dir/saved_ansi_gcl_new

build_error()
{
        echo "Error building $1" 1>&2
        exit 1
}

image_error()
{
        echo "Error moving new lisp image $new_image" 1>&2
        exit 1
}

command=$1
shift

case $command in
rebuild)
        echo $progname Rebuilding ...
        while test -x $gcl -a -n "$1"
        do
                echo $progname rebuilding $1
                $gcl -batch -eval "
(progn
  (handler-case
    (progn
      (c-l-c:compile-library (quote $1))
      (quit 0))
    (error (err)
      (ignore-errors (format t \"~&Build error: ~A~%\" err))
      (finish-output)
      (quit 1)))) " || build_error $1
                shift
        done 
        ;;

remove)
        echo $progname Removing ...
        while test -n "$1"
                echo $progname removing $1
        do
                rm -rf "$gcl_clc/$1"
                shift
        done
        rmdir $gcl_clc 2> /dev/null 
        ;;

install-clc)
        echo $progname Installing clc ...
        if test ! -f $pristine_image; then
                mv -f $image $pristine_image
                cp -f $pristine_image $image
        fi
        if test -x $gcl; then
                $gcl -batch -eval "
(handler-case
  (progn 
    ;; A temporary condition until _after_ GCL version 2.6.2 
    (in-package :common-lisp)
    (unless (fboundp 'load-time-value)
            (defun load-time-value (obj) obj)
            (export (find-symbol \"LOAD-TIME-VALUE\")))

    (in-package :common-lisp-user)
    (load 
\"/usr/share/common-lisp/source/common-lisp-controller/common-lisp-controller.lisp\")

;;;; XXX This fails currently due to obsolete pathnames
;;;; XXX ANSI standard pathnames is needed to continue work.
;;;; XXX There may be potential problems with packages,
;;;; XXX but may just be a side-effect from pathname errors...
    (in-package :common-lisp-controller)
    (init-common-lisp-controller \"$gcl_clc\" :version 3)

    (defun send-clc-command (command package)
      \"Overrides global definition.\"
      (multiple-value-bind (exit-code signal-code)
                (si::system (c-l-c:make-clc-send-command-string
                              command package \"gcl\"))
        (if (and (zerop exit-code) (zerop signal-code))
            (values)
            (error \"Error during ~A of ~A for ~A~%Please see 
/usr/share/doc/common-lisp-controller/REPORTING-BUGS.gz\"
                   (ecase command
                          (:recompile \"recompilation\")
                          (:remove \"removal\"))
                   package
                   \"gcl\"))))

    (si:save-system \"$new_image\")
    (quit 0))
  (error (err)
    (ignore-errors (format t \"~&Install-clc error: ~A~%\" err))
    (finish-output)
    (quit 1)))" || build_error send-clc-command
                mv -f $new_image $image || image_error
        fi
        ;;

remove-clc)
        echo $progname Uninstalling clc and restoring pristine (orig) image ...
        if test -f $pristine_image; then
                cp -f $pristine_image $image
        else
                echo "Cannot find pristine image file $pristine_image." 1>&2
        fi
        ;;

make-user-image)
        echo $progname Building image with $1 ...
        if test ! -r $1; then 
                echo "Trying to make user image: Cannot access file $1" 1>&2
                exit 1
        fi 
        $gcl -batch -eval "
(progn    
  (load \"$1\") 
  (si:save-system \"$new_image\")
  (quit 0))" || build_error $1
        mv -f $new_image $image || image_error
        ;;

*)
        expr $command : '.*\(help\).*' > /dev/null 2>&1 || \
                echo "$progname: Unknown command '$command'" 1>&2
        echo "Usage: $progname <command>" 1>&2 
        echo "Where <command> is one of:" 1>&2
        echo "  install-clc, remove-clc," 1>&2
        echo "  rebuild <package>*, remove <package>*," 1>&2
        echo "  or make-user-image <load-file>" 1>&2
        echo "And <package> is a cl-debpkg (e.g. cl-rt)" 1>&2
        echo "  with a defsystem/asdf definition." 1>&2
        exit 1
        ;;
esac

exit 0
=====

Put it in /usr/lib/common-lisp/bin/
and you are ready to go ...

Dennis Decker Jensen


"Organizations which design systems are constrained to produce
designs which are copies of the communication structures of these
organizations."
 -- Melvin Conway, 1968

"Conway's Law: The structure of a system reflects the structure
of the organization that built it.

Conway's Law has been stated even more strongly:
The structure of any system designed by an organization
is isomorphic to the structure of the organization."
 -- Edward Yourdon and Larry L. Constantine, 1979