Lisp in Basic

[JRS]

I know this works as here is the script that built the attach tests directory. It used libcurl to download the file, extracted the source and built this monster with both C and ecl. I'm thinking this has real possibilities.

Code: [Select]

;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;;
;;; (c) 2011, Juan Jose Garcia-Ripoll
;;;
;;; Set up the test environment.
;;;

(defpackage :ecl-tests
  (:use :cl))

(in-package :ecl-tests)

(setf *load-verbose* nil *load-print* nil)

(defvar *ecl-sources*
  (loop for *default-pathname-defaults* in
'(#p"/home/jrs/ecl/src/" #p"../../" #p"../../src/")
when (probe-file "CHANGELOG")
return *default-pathname-defaults*))

(defvar *test-sources* (merge-pathnames "tests/" *ecl-sources*))

(defvar *here* (merge-pathnames "./"))

(defvar *cache* (merge-pathnames "./cache/" *here*))

(defvar *test-image* (or (ext:getenv "TEST_IMAGE")
#+windows
(namestring (truename #+windows "sys:ecl.exe"))
#-windows
"ecl"))

(defvar *test-image-args*
  (cond ((search "ecl" *test-image*)
'("-norc" "-eval" "(print (ext:getenv \"ECLDIR\"))"
   ;#+windows "-eval" #+windows "(require :cmp)"
   ))
((search "sbcl" *test-image*)
'("--no-userinit" "--no-sysinit"))
(t
'())))

#+ecl
(ext:setenv "ECLDIR" (namestring (truename "SYS:")))

(defvar *test-name* (or (ext:getenv "TEST_NAME") "ecl"))

(defvar *output-directory*
  (merge-pathnames (concatenate 'string "output." *test-name* "/") *here*))

(defvar *quicklisp-sandbox* (merge-pathnames "quicklisp/" *here*))

(defvar *quicklisp-install-file* (merge-pathnames "quicklisp.lsp" *cache*))

(defvar *quicklisp-setup-file* (merge-pathnames "setup.lisp" *quicklisp-sandbox*))

(defvar *regressions-sources* (merge-pathnames "bugs/" *test-sources*))

(defvar *regressions-sandbox* (merge-pathnames "regressions/" *here*))

(defvar *ansi-tests-mirror* "http://ecls.sourceforge.net/ansi-tests.tar.gz")

(defvar *ansi-tests-sandbox* (merge-pathnames "ansi-tests/" *here*))

(defvar *ansi-tests-tarball* "ansi-tests.tar.gz")

(defvar *mop-tests-mirror* "http://ecls.sourceforge.net/mop-features.tar.gz")

(defvar *mop-tests-sandbox* (merge-pathnames "mop-features/" *here*))

(defvar *mop-tests-tarball* "mop-features.tar.gz")

(defvar *fricas-mirror* "http://ecls.sourceforge.net/fricas.tar.gz")

(defvar *fricas-sandbox* (merge-pathnames "fricas/" *here*))

(defvar *fricas-tarball* "fricas.tar.gz")

(defvar *wild-inferiors* (make-pathname :name :wild
:type :wild
:version :wild
:directory '(:relative :wild-inferiors)))

(defvar *cleanup-extensions* '("fasl" "fasb" "c" "h" "obj" "o" "a" "lib" "dll" "dylib" "data"))

(defun lisp-system-directory ()
  (loop with root = (si::get-library-pathname)
with lib-name = (format nil "../lib/ecl-~A/" (lisp-implementation-version))
for base in (list root (merge-pathnames lib-name root))
when (or (probe-file (merge-pathnames "./BUILD-STAMP" base))
(probe-file (merge-pathnames "./LGPL" base)))
do (return base)))

(setf (logical-pathname-translations "SYS")
      (list (list #p"sys:**;*.*"
  (merge-pathnames "**/*.*"
   (lisp-system-directory)))))

(require :cmp)
(require :ecl-curl)
(require :deflate)
(require :ql-minitar)

;;;
;;; PREPARATION OF DIRECTORIES AND FILES
;;;

(defun setup-asdf ()
  (require :asdf)
  (ensure-directories-exist *cache*)
  (setf (symbol-value (read-from-string "asdf::*user-cache*"))
(list *cache* :implementation)))
     

(defun delete-everything (path)
  ;; Recursively run through children
  (labels ((recursive-deletion (path)
             (mapc #'delete-everything
                   (directory (merge-pathnames
                               (make-pathname :name nil
                                              :type nil
                                              :directory '(:relative :wild)
                                              :defaults path)
                               path)))
             ;; Delete files
             (loop for f in (directory (make-pathname :name :wild
                                                      :type :wild
                                                      :defaults path))
                do (delete-file f)
                finally (delete-file path))))
    (and (probe-file path)
         (recursive-deletion path))))

(defun safe-download (url filename)
  (ensure-directories-exist filename)
  (handler-case
      (ecl-curl:download-url-to-file url filename)
    (ecl-curl:download-error (c)
      (format t "~&;;;~%;;; Unable to download quicklisp. Aborting. ~%;;;")
      (ext:quit 1)))
  filename)

(defun download-quicklisp-install ()
  (safe-download "http://beta.quicklisp.org/quicklisp.lisp"
*quicklisp-install-file*))

(defun download-and-setup-quicklisp ()
  (when (probe-file *quicklisp-sandbox*)
    (delete-everything *quicklisp-sandbox*))
  (handler-case
      (progn
(load (download-quicklisp-install))
(let ((function (read-from-string "quicklisp-quickstart:install")))
  (eval (list function :path *quicklisp-sandbox*))))
    (error (c)
      (format t "~&;;;~%;;; Unable to setup quicklisp. Aborting.~%;;;")
      (delete-everything *quicklisp-sandbox*))))

(defun ensure-quicklisp ()
  (unless (find-package "QL")
    (unless (probe-file *quicklisp-sandbox*)
      (setup-asdf)
      (download-and-setup-quicklisp))
    (load *quicklisp-setup-file*))
  t)

(defun copy-directory (orig dest)
  (setf orig (truename orig))
  (print dest)
  (loop for f in (directory (merge-pathnames *wild-inferiors* orig))
     for f2 = (enough-namestring f orig)
     for f3 = (merge-pathnames f2 dest)
     unless (probe-file f3)
     do (ensure-directories-exist f3)
     do (ext:copy-file f f3)))

(defun extract-tarball (filename)
  (format t "~&;;;~%;;; Extracting ~a~%;;;" filename)
  (if (string-equal (pathname-type filename) "gz")
      (let ((temp-filename (ext:mkstemp "fooXXXXXXX")))
(unwind-protect
     (progn
       (deflate:gunzip filename temp-filename)
       (extract-tarball temp-filename))
  (delete-file temp-filename)))
      (ql-minitar:unpack-tarball filename)))

(defun extract-distribution (filename url)
  (let ((distribution (loop for base in (list *cache*
      *here*
      *test-sources*)
for file = (merge-pathnames filename base)
when (probe-file file)
do (return file)
finally (let ((tmp (merge-pathnames filename *cache*)))
   (return (safe-download url tmp))))))
    (extract-tarball distribution)))

(defun ensure-regressions ()
  (unless (probe-file *regressions-sandbox*)
    (copy-directory *regressions-sources* *regressions-sandbox*)))

(defun ensure-ansi-tests ()
  (unless (probe-file *ansi-tests-sandbox*)
    (extract-distribution *ansi-tests-tarball* *ansi-tests-mirror*))
  t)

(defun ensure-mop-tests ()
  (unless (probe-file *mop-tests-sandbox*)
    (extract-distribution *mop-tests-tarball* *mop-tests-mirror*))
  t)

(defun ensure-fricas ()
  (unless (probe-file *fricas-sandbox*)
    (extract-distribution *fricas-tarball* *fricas-url*)))

(defun ensure-maxima ()
  (unless (probe-file *fricas-sandbox*)
    (extract-distribution *fricas-tarball* *fricas-url*)))

(defun cleanup-directory (path)
  (loop for i in (directory (merge-pathnames *wild-inferiors*
     path))
     when (member (pathname-type i) *cleanup-extensions* :test #'string-equal)
     do (delete-file i)))

;;;
;;; RUNNING TESTS
;;;

(defun run-ansi-tests (&optional (output (merge-pathnames "ansi.log"
  *output-directory*)))
  (ensure-ansi-tests)
  ;; Cleanup stray files
  (cleanup-directory *ansi-tests-sandbox*)
  (delete-everything (merge-pathnames "scratch/" *ansi-tests-sandbox*))
  ;; Run with given image
  (ensure-directories-exist output)
  (let* ((input (merge-pathnames "doit.lsp" *ansi-tests-sandbox*))
(tmp (merge-pathnames "ecl-tmp-doit.lsp" *ansi-tests-sandbox*)))
    (with-open-file (s tmp :direction :output
       :if-exists :supersede
       :if-does-not-exist :create)
      (format s "(require :cmp)
#+ecl(setf c::*suppress-compiler-messages* '(or c::compiler-note c::style-warning))
(pprint (ext:getcwd))
(load ~S)
#+ecl(quit)"
      (namestring input)))
    (unwind-protect
(progn
  (ext:chdir *ansi-tests-sandbox*)
  (ext:run-program *test-image*
   *test-image-args*
   :input tmp
   :output output
   :error :output
   :wait t))
      (when (probe-file tmp)
(ignore-errors (delete-file tmp)))
      (ext:chdir *here*))))

(defun run-regressions-tests (&optional (output (merge-pathnames "regressions.log"
*output-directory*)))
  (ensure-regressions)
  ;; Cleanup stray files
  (cleanup-directory *regressions-sandbox*)
  ;; Run with given image
  (ensure-directories-exist output)
  (unwind-protect
       (progn
(ext:chdir *regressions-sandbox*)
(ext:run-program *test-image*
  *test-image-args*
  :input (merge-pathnames "doit.lsp" *regressions-sandbox*)
  :output output
  :error :output))
    (ext:chdir *here*)))

(defun run-mop-tests (&optional (output (merge-pathnames "mop-features.log"
*output-directory*)))
  (ensure-mop-tests)
  ;; Cleanup stray files
  (cleanup-directory *mop-tests-sandbox*)
  ;; Create the script we are going to run
  (let ((mop-script (merge-pathnames "./run-mop-tests.lisp" *mop-tests-sandbox*)))
    (with-open-file (s mop-script :direction :output
       :if-exists :supersede
       :if-does-not-exist :create)
      (pprint '(progn
(require :asdf)
(load "lw-compat-package")
(load "lw-compat")
(load "mop-features-packages.lisp")
(load "mop-feature-tests.lisp")
(handler-case
    (progn
      (funcall (read-from-string "mop-feature-tests::run-feature-tests"))
      (format t "~%~%~%MOP-FEATURE-TESTS: OK"))
  (error (error)
    (format t "~%~%~%MOP-FEATURE-TESTS: Failed"))))
      s))
    ;; Run with given image
    (ensure-directories-exist output)
    (unwind-protect
(progn
   (ext:chdir *mop-tests-sandbox*)
   (ext:run-program *test-image*
    *test-image-args*
    :input mop-script
    :output output
    :error :output))
      (ext:chdir *here*))))


(defvar *quicklisp-library-list*
  '(trivial-features
    alexandria
    babel
    cffi
    cl-ppcre
    cl-unicode
    iterate
    trivial-gray-streams
    trivial-garbage
    flexi-streams
    lift
    metabang-bind
    swank
    stefil
    sqlite
    chunga
    cl+ssl
    cl-base64
    cl-fad
    cl-python
    md5
    rfc2388
    trivial-backtrace
    trivial-gray-streams
    usocket
    hunchentoot))

(defconstant +quicklisp-build-template+ "
(require 'asdf)
(setf (symbol-value (read-from-string \"asdf::*user-cache*\"))
      (list ~s :implementation))
(load ~s)
(ql:use-only-quicklisp-systems)
(handler-case
  (progn
    (ql:quickload ~s)
    (princ \"ECL-BUILD-OK\"))
  (serious-condition (c) (princ c)))
#+ecl
(ext:quit)
#+sbcl
(sb-ext:quit)
")

(defconstant +quicklisp-test-template+ "
(require 'asdf)
(setf (symbol-value (read-from-string \"asdf::*user-cache*\"))
      (list ~s :implementation))
(load ~s)
(ql:use-only-quicklisp-systems)
(handler-case
  (progn
    (ql:quickload ~s)
    (princ \"ECL-BUILD-OK\")
    (asdf:oos 'asdf:test-op ~:*~s)
    (princ \"ECL-TEST-OK\"))
  (serious-condition (c) (princ c)))
#+ecl
(ext:quit)
#+sbcl
(sb-ext:quit)
")

(defun run-quicklisp-tests (&optional (output (merge-pathnames "quicklisp.log"
       *output-directory*)))
  (mapcar #'delete-everything (directory (merge-pathnames "*/" *cache*)))
  (let ((quicklisp-logs (merge-pathnames "quicklisp.logs/" *output-directory*)))
    (labels ((build-or-test-job (name suffix template)
       (let* ((name (string-downcase name))
      (log-name (concatenate 'string name suffix))
      (build-log (ensure-directories-exist
  (merge-pathnames log-name quicklisp-logs))))
(multiple-value-bind (stream status process)
     (ext:run-program *test-image*
      *test-image-args*
      :input :stream
      :output build-log
      :error :output
      :wait nil)
   (unwind-protect
(progn
  (format stream template
  (namestring *cache*)
  (namestring *quicklisp-setup-file*)
  name)
  (format t template
  (namestring *cache*)
  (namestring *quicklisp-setup-file*)
  name)
  (force-output stream))
     (close stream)
     (ext:external-process-wait process t)
     ))))
     (build-job (name)
       (build-or-test-job name "-build.log" +quicklisp-build-template+))
     (test-job (name)
       (build-or-test-job name "-test.log" +quicklisp-test-template+)))
      (mapc #'build-job *quicklisp-library-list*)
      (mapc #'test-job *quicklisp-library-list*))))

Loading a library from ecl lisp.

Code: [Select]

(load-foreign-library #p"/usr/lib/libmysqlclient.so"
                      :module "mysql"
                     :supporting-libraries '("c"))
=> T


.

[JRS]

I still have a lot of reading to do but what I'm seeing so far is ECL (Embedded Common Lisp) allows you to create linked libraries and standalone binaries in Common Lisp as well as an API that allows Lisp functionality from the hosting language as function calls. Has anyone else looked at this?

[Mike Lobanovsky]

Supposedly "anyone else" is me.

All this embedding, compilation, linking, modularizing, etc. stuff is OK for Linux but KO for Windows and Mac OS X. We do not have a system compiler and gigs of object libraries to match. Windows and Mac users are white- and blue-collar workers, intellectuals, and artists but not red eyed terminal happy coding geeks nor freaks.

Apart from that, this ECL thingy looks like an exact match to SB's own design and workflow in its Linux hypostasis. The other platforms may be satisfied with a standalone SB interpreter and a matching LISP bytecode interpreter DLL/DYLIB plug-in.

[JRS]

Apart from that, this ECL thingy looks like an exact match to SB's own design and workflow in its Linux hypostasis. The other platforms may be satisfied with a standalone SB interpreter and its matching LISP bytecode interpreter plug-in.

I was wondering what your take was on this. It's seems like Lisp Christmas for Linux and tailored for environments like SB. I hope that FBSL not being ported to Linux yet doesn't keep you away from experimenting with tools on that platform.

 

[Mike Lobanovsky]

I hope that FBSL not being ported to Linux yet doesn't keep you away from experimenting with tools on that platform.

No, it doesn't. You have just reported that my fixes to your initial submission of SBLisp are working perfectly well under your 64-bit Ubuntu as well as my 32-bit Windows.

From an outsider's perspective, ECL looks like a project of quality and ambition comparable with SB. OTOH SBLisp doesn't and it will never be anything but a toy as long as it stays written in SB. Go ahead with ECL, John, it would be much more reasonable to do than try and rewrite SBLisp in CBASIC. That is if you are seriously planning to enrich SB with another language similar to how O2 is enriched with assembly, and FBSL, with DynC and DynAsm.

[JRS]

It would be great if you can find the time to mentor me along with the ECL effort on Linux. When I created the SB SDL GFX extension module in C BASIC, it only took a few tweaks to use the same C BASIC library with BaCon. I guess my point is that your efforts wouldn't be SB specific but a common language binding effort of how to embed Lisp with C. We used SB as a testing ground for proof of concept. It's just easy to use.

I agree that SBLisp is a toy and a fun way to learn Lisp without a lot of pain. I can't thank you enough for all the help and code bringing that to a reality. I enjoy working with you and hope that doesn't stop with the common effort SBLisp, FBLisp and OxyLisp project.

[Mike Lobanovsky]

We used SB as a testing ground for proof of concept. It's just easy to use.

Naturally enough, FBSL is the easiest for me. Oxygen stays the toughest. The OxyLISP evaluator still fails me, or rather I'm failing as an O2 user.

I can't thank you enough for all the help and code bringing that to a reality.

Thank you for the kind words. Actually I'm a steppen wolf when coding but this thread did bring a lot of life and entertainment to my LISP dev experience.

As for the rest of it, I'm feeling obliged to bring OxyLISP to completion. I'll probably spawn another topic where it's going to be the subject matter, its SB and FBSL siblings staying in the background as reference models.

Then what? Frankly, I don't know yet. Probably, back to FBSL v3.5 RC3 and Final.

[JRS]

I'm happy where SBLisp is currently. If someone finds a bug, I'll be sure to look into it. (Translation: Mike, we got a bug in ...)

[Mike Lobanovsky]

Where?! 

[JRS]

Here is where I'm at currently. (Hint: GCL GNU Common-Lisp)

Code: [Select]

(defun fibonacci (n)
  (if (< n 3)
      1
      (+ (fibonacci (- n 1)) (fibonacci (- n 2))) ) )

(loop for i from 1 to 24
   do (format t "~D, " (fibonacci i))
   finally (format t "...~%") )

jrs@laptop:~/gcl$ time gcl -batch -load /home/jrs/gcl/fibonacci.lsp
1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987, 1597, 2584, 4181, 6765, 10946, 17711, 28657, 46368, ...

real   0m0.174s
user   0m0.148s
sys   0m0.020s
jrs@laptop:~/gcl$

[Mike Lobanovsky]

Phew!

Easy John, I shouldn't be having blood pressure jumps like that at 3 in the morning...

Why should it be called a "bug"? This is a totally alien syntax and this functionality is missing from the original Lisp-in-Basic. That's like expecting raw C code to run in the SB interpreter.

<suspicion> Or are you implying you've gone that far in putting your SBLisp syntax on the GCL rails?! </suspicion>

[JRS]

<suspicion> Or are you implying you've gone that far in putting your SBLisp on the GCL rails?! </suspicion>

Nope. Just tried the GCL interpreter to see what it will do on the track. 

Can't imagine what it will be like when compiled to C.

[Mike Lobanovsky]

You mean, speed-wise?

BTW all this can be rewritten in the existing SBLisp. I'm too tired tonight (it's been my youngest son's 16th birthday party today -- your time). Adulthood and stuff. Temptations and responsibilities. But I can do it for you tomorrow. Not very difficult actually except for tricky print formating. Remember, we can't print a space yet.

[JRS]

You mean, speed-wise?

Yes. Are you saying the fibonacci.lsp script I found and posted for GNU Common Lisp is more efficient and will produce better numbers under our current SBLisp/FBLisp versions?

I think we should add a DEBUG flag and only show GC start GC finish and other annoying print messages only when enabled.

[Mike Lobanovsky]

Of course not. The execution time will be on the order of 10 seconds or more. But it will print its intermediate results separated with a comma and it will even add the trailing ellipsis. There will be no spaces though.

You can add command line options easily. Let your initial command line evaluator do, say, a INSTR(COMMAND(), " -d ") or INSTR(COMMAND(), " /d ") search for trailing options, adjust the flags accordingly, and chop the command line with a matching RTRIM(LEFT(COMMAND(),INSTR(...))) at the first option found to let the remaining command line serve as the file name to load and execute. Voila.

[EDIT] FBSL features a Command(N) function and a matching CommandCount() function with all the space delimited command line elements pre-parsed and ready for iteration.