Evaluating Medley compatibility with Practical Common Lisp code: Chapter 20

[pamoroso]

Chapter 20. The Special Operators

This is the continuation of the work on issue #609. To evaluate the compatibility of Medley Common Lisp with ANSI Common Lisp I'm testing on Medley the code of Peter Seibel's book Practical Common Lisp.

Code

For the code of chapter 20, after adding the usual missing definitions and calls I created the following files:

;;; pclchap20f1.lisp

(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf *package* (find-package "IL")))

and:

;;; pclchap20f2.lisp

(defun when-loaded () (load-time-value (get-universal-time)))

Then I evaluated these expressions at a XCL Exec:

(defun collect-leaves (tree)
  (let ((leaves ()))
    (labels ((walk (tree)
               (cond
                 ((null tree))
                 ((atom tree) (push tree leaves))
                 (t (walk (car tree))
                    (walk (cdr tree))))))
      (walk tree))
    (nreverse leaves)))

(collect-leaves '(a (b c) (d (e f))))

(dotimes (i 10)
  (let ((answer (random 100)))
    (print answer)
    (if (> answer 50) (return))))

(tagbody
 top
   (print 'hello)
   (go top))

(tagbody
 top
   (print 'hello)
   (when (plusp (random 10)) (go top)))

(tagbody
 a (print 'a) (if (zerop (random 2)) (go c))
 b (print 'b) (if (zerop (random 2)) (go a))
 c (print 'c) (if (zerop (random 2)) (go b)))

(defun algorithm-s (n max)
  (let (seen
        selected
        u
        (records ()))
    (tagbody
     s1
       (setf seen 0)
       (setf selected 0)
     s2
       (setf u (random 1.0))
     s3
       (when (>= (* (- max seen) u) (- n selected)) (go s5))
     s4
       (push seen records)
       (incf selected)
       (incf seen)
       (if (< selected n)
           (go s2)
           (return-from algorithm-s (nreverse records)))
     s5
       (incf seen)
       (go s2))))

(algorithm-s 3 20)

(defun algorithm-s (n max)
  (loop for seen from 0
     when (< (* (- max seen) (random 1.0)) n)
     collect seen and do (decf n)
     until (zerop n)))

(algorithm-s 3 20)

(defun foo ()
  (format t "Entering foo~%")
  (block a
    (format t " Entering BLOCK~%")
    (bar #'(lambda () (return-from a)))
    (format t " Leaving BLOCK~%"))
  (format t "Leaving foo~%"))

(defun bar (fn)
  (format t "  Entering bar~%")
  (baz fn)
  (format t "  Leaving bar~%"))

(defun baz (fn)
  (format t "   Entering baz~%")
  (funcall fn)
  (format t "   Leaving baz~%"))

(foo)

(defun bar (fn)
  (format t "  Entering bar~%")
  (block a (baz fn))
  (format t "  Leaving bar~%"))

(foo)

(defparameter *obj* (cons nil nil))

(defun foo ()
  (format t "Entering foo~%")
  (catch *obj*
    (format t " Entering CATCH~%")
    (bar)
    (format t " Leaving CATCH~%"))
  (format t "Leaving foo~%"))

(defun bar ()
  (format t "  Entering bar~%")
  (baz)
  (format t "  Leaving bar~%"))

(defun baz ()
  (format t "   Entering baz~%")
  (throw *obj* nil)
  (format t "   Leaving baz~%"))

(foo)

(defun open-connection (&rest args)
  (declare (ignorable args))
  (format t "~&Opening DB connection...~%")
  t)

(defun close-connection (connection)
  (declare (ignorable connection))
  (format t "~&Closing DB connection...~%")
  t)

(defun do-stuff (&rest connection)
  (declare (ignorable connection))
  (format t "~&Doing stuff...~%")
  t)

(defun do-more-stuff (&rest connection)
  (declare (ignorable connection))
  (format t "~&Doing more stuff...~%")
  t)

(defmacro with-database-connection ((var &rest open-args) &body body)
  `(let ((,var (open-connection ,@open-args)))
    (unwind-protect (progn ,@body)
      (close-connection ,var))))

(with-database-connection (conn :host "foo" :user "scott" :password "tiger")
  (do-stuff conn)
  (do-more-stuff conn))


(funcall #'+ (values 1 2) (values 3 4))

(multiple-value-call #'+ (values 1 2) (values 3 4))

(multiple-value-bind (x y) (values 1 2)
  (+ x y))

(multiple-value-list (values 1 2))

(values-list (multiple-value-list (values 1 2)))

(defparameter *x* nil)

(defparameter *y* nil)

(setf (values *x* *y*) (floor (/ 57 34)))

*x*

*y*

(progn (load "pclchap20f1.lisp") *package*)

(setf *package* (find-package "XCL-USER"))

; load
(load "pclchap20f2.lisp")

(when-loaded)

Issues

The code worked as expected except for the following potential issues:

• the error VALUES is not a known location specifier for SETF points out that values is not setfable on Medley
• I'm not sure loading pclchap20f1.lisp works as expected
• I don't know why loading pclchap20f1.lisp yields the error Undefined car of form WHEN-LOADED
• LOAD-TIME-VALUE is not supported on Medley

Session transcript

Here is the full transcript of the test session, from which I edited out part of the output of an intentional infinite loop I interrupted with Ctrl-E:

NIL
2/8> (defun collect-leaves (tree)
  (let ((leaves ()))
    (labels ((walk (tree)
               (cond
                 ((null tree))
                 ((atom tree) (push tree leaves))
                 (t (walk (car tree))
                    (walk (cdr tree))))))
      (walk tree))
    (nreverse leaves)))
COLLECT-LEAVES
2/9> 

2/9> (collect-leaves '(a (b c) (d (e f))))
(A B C D E F)
2/10> 

2/10> (dotimes (i 10)
  (let ((answer (random 100)))
    (print answer)
    (if (> answer 50) (return))))

55 
NIL
2/11> 

2/11> (tagbody
 top
   (print 'hello)
   (go top))

HELLO 
HELLO 
;;; [...]
HELLO 
HELLO 
HE ; Ctrl-E

2/12> (tagbody
 top
   (print 'hello)
   (when (plusp (random 10)) (go top)))

HELLO 
NIL
2/13> 

2/13> (tagbody
 a (print 'a) (if (zerop (random 2)) (go c))
 b (print 'b) (if (zerop (random 2)) (go a))
 c (print 'c) (if (zerop (random 2)) (go b)))

A 
B 
C 
NIL
2/14> 

2/14> (defun algorithm-s (n max)
  (let (seen
        selected
        u
        (records ()))
    (tagbody
     s1
       (setf seen 0)
       (setf selected 0)
     s2
       (setf u (random 1.0))
     s3
       (when (>= (* (- max seen) u) (- n selected)) (go s5))
     s4
       (push seen records)
       (incf selected)
       (incf seen)
       (if (< selected n)
           (go s2)
           (return-from algorithm-s (nreverse records)))
     s5
       (incf seen)
       (go s2))))
ALGORITHM-S
2/15> 

2/15> (algorithm-s 3 20)
(0 16 19)
2/16> 

2/16> (defun algorithm-s (n max)
  (loop for seen from 0
     when (< (* (- max seen) (random 1.0)) n)
     collect seen and do (decf n)
     until (zerop n)))

New FUNCTIONS definition for ALGORITHM-S.
ALGORITHM-S
2/17> 

2/17> (algorithm-s 3 20)
(13 15 16)
2/18> 

2/18> (defun foo ()
  (format t "Entering foo~%")
  (block a
    (format t " Entering BLOCK~%")
    (bar #'(lambda () (return-from a)))
    (format t " Leaving BLOCK~%"))
  (format t "Leaving foo~%"))
FOO
2/19> 

2/19> (defun bar (fn)
  (format t "  Entering bar~%")
  (baz fn)
  (format t "  Leaving bar~%"))
BAR
2/20> 

2/20> (defun baz (fn)
  (format t "   Entering baz~%")
  (funcall fn)
  (format t "   Leaving baz~%"))
BAZ
2/21> 

2/21> (foo)
Entering foo
 Entering BLOCK
  Entering bar
   Entering baz
Leaving foo
NIL
2/22> 

2/22> (defun bar (fn)
  (format t "  Entering bar~%")
  (block a (baz fn))
  (format t "  Leaving bar~%"))

New FUNCTIONS definition for BAR.
BAR
2/23> 

2/23> (foo)
Entering foo
 Entering BLOCK
  Entering bar
   Entering baz
Leaving foo
NIL
2/24> 

2/24> (defparameter *obj* (cons nil nil))
*OBJ*
2/25> 

2/25> (defun foo ()
  (format t "Entering foo~%")
  (catch *obj*
    (format t " Entering CATCH~%")
    (bar)
    (format t " Leaving CATCH~%"))
  (format t "Leaving foo~%"))

New FUNCTIONS definition for FOO.
FOO
2/26> 

2/26> (defun bar ()
  (format t "  Entering bar~%")
  (baz)
  (format t "  Leaving bar~%"))

New FUNCTIONS definition for BAR.
BAR
2/27> 

2/27> (defun baz ()
  (format t "   Entering baz~%")
  (throw *obj* nil)
  (format t "   Leaving baz~%"))

New FUNCTIONS definition for BAZ.
BAZ
2/28> 

2/28> (foo)
Entering foo
 Entering CATCH
  Entering bar
   Entering baz
Leaving foo
NIL
2/29> 

2/29> (defun open-connection (&rest args)
  (declare (ignorable args))
  (format t "~&Opening DB connection...~%")
  t)
OPEN-CONNECTION
2/30> 

2/30> (defun close-connection (connection)
  (declare (ignorable connection))
  (format t "~&Closing DB connection...~%")
  t)
CLOSE-CONNECTION
2/31> 

2/31> (defun do-stuff (&rest connection)
  (declare (ignorable connection))
  (format t "~&Doing stuff...~%")
  t)
DO-STUFF
2/32> 

2/32> (defun do-more-stuff (&rest connection)
  (declare (ignorable connection))
  (format t "~&Doing more stuff...~%")
  t)
DO-MORE-STUFF
2/33> 

2/33> (defmacro with-database-connection ((var &rest open-args) &body body)
  `(let ((,var (open-connection ,@open-args)))
    (unwind-protect (progn ,@body)
      (close-connection ,var))))
WITH-DATABASE-CONNECTION
2/34> 

2/34> (with-database-connection (conn :host "foo" :user "scott" :password "tiger")
  (do-stuff conn)
  (do-more-stuff conn))
Opening DB connection...
Doing stuff...
Doing more stuff...
Closing DB connection...
T
2/35> 

2/35> 
2/35> (funcall #'+ (values 1 2) (values 3 4))
4
2/36> 

2/36> (multiple-value-call #'+ (values 1 2) (values 3 4))
10
2/37> 

2/37> (multiple-value-bind (x y) (values 1 2)
  (+ x y))
3
2/38> 

2/38> (multiple-value-list (values 1 2))
(1 2)
2/39> 

2/39> (values-list (multiple-value-list (values 1 2)))
1
2
2/40> 

2/40> (defparameter *x* nil)
*X*
2/41> 

2/41> (defparameter *y* nil)
*Y*
2/42> 

2/42> (setf (values *x* *y*) (floor (/ 57 34)))
VALUES is not a known location specifier for SETF.

2/43> 

2/43> *x*
NIL
2/44> 
*y*
NIL
2/45> 
(progn (load "pclchap20f1.lisp") *package*)

; Loading {DSK}<home>medley>il>demo>pclchap20f1.lisp;1
; Finished loading {DSK}<home>medley>il>demo>pclchap20f1.lisp;1, 117 bytes read
#<Package XCL-USER>
2/46> 

2/46> (setf *package* (find-package "XCL-USER"))
#<Package XCL-USER>
2/47> 

2/47> ; load
(load "pclchap20f2.lisp")

; Loading {DSK}<home>medley>il>demo>pclchap20f2.lisp;1
; Finished loading {DSK}<home>medley>il>demo>pclchap20f2.lisp;1, 84 bytes read
IL:|{DSK}<home>medley>il>demo>pclchap20f2.lisp;1|
2/48> 
(when-loaded)
Undefined car of form
WHEN-LOADED

2/49>