bloop

geb-bloop-user.lisp

;; Gödel Escher Bach - BlooP language snippets

(defpackage #:snippets/geb-bloop-user
  (:use #:cl #:snippets/geb-bloop))

(in-package #:snippets/geb-bloop-user)

(defprim add (x y) (+ x y))
(defprim mul (x y) (* x y))
(defprim equ (x y) (if (= x y) 1 0))
(defprim max (x y))

(defproc calc-2^3^n (n)
  (setq 3^n 1)
  (bounded-loop (i n)
    (setq 3^n (mul 3^n 3)))
  (setq output 1)
  (bounded-loop (i 3^n)
    (setq output (mul output 2))))

(defmac if-then (test then)
  (let ((i (gensym))
        (b (gensym)))
    `(bounded-loop (,i ,test ,b)
       ,then)))

(defproc smaller (x y)
  (if-then (equ x y)
           (return-from smaller 0))
  (if-then (equ (max x y) x)
           (return-from smaller 0))
  (setq output 1))

(defproc minus (m n)
  (if-then (smaller m n)
           (return-from minus 0))
  (bounded-loop (i (add m 1))
    (if-then (equ (add output n) m)
             (return-from nil))
    (setq output (add output 1))))

;; QUIT and ABORT are too lame to implement, talking about "lines" of
;; code.  It is of course possible to interpret them as talking about
;; forms, but they'd be unnecessary given that BOUNDED-LOOP can take
;; an optional block name.

(defconstant no 0)
(defconstant yes 1)

;; Really stupid implementation...
(defproc remainder (m n)
  (bounded-loop (i (max m n))
    (if-then (equ m n)
             (return-from remainder 0))
    (if-then (smaller m n)
             (return-from remainder m))
    (setq m (minus m n)))
  (setq output m))

;; The definition in the book returns YES for 1...
(defproc prime? (n)
  (if-then (equ n 0)
           (return-from prime? no))
  (if-then (equ n 1)
           (return-from prime? no))
  (setq m 2)
  (bounded-loop (i (minus n 2))
    (if-then (equ (remainder n m) 0)
             (return-from prime? no))
    (setq m (add m 1)))
  (setq output yes))

(defmac und (x y)
  (let ((b (gensym)))
    `(block ,b
       (if-then ,x
                (if-then ,y
                         (return-from ,b yes)))
       no)))

(defproc goldbach? (n)
  (setq m 2)
  (bounded-loop (i n)
    (if-then (und (prime? m)
                  (prime? (minus n m)))
             (return-from goldbach? yes))
    (setq m (add m 1))))

(defproc factorial (n)
  (if-then (equ n 0)
           (return-from factorial no))
  (setq m n)
  (bounded-loop (i (minus n 1))
    (setq m (mul m (add i 1))))
  (setq output m))

(defproc tortoise-pair? (m n)
  (setq output
        (und (prime? m)
             (prime? (add m n)))))

geb-bloop.lisp

;; Gödel Escher Bach - BlooP language

(defpackage #:snippets/geb-bloop
  (:use #:cl)
  (:export
   #:bounded-loop
   #:defmac
   #:defprim
   #:defproc
   #:output))

(in-package #:snippets/geb-bloop)

(defmacro bounded-loop ((i upper-bound-form &optional block-name) &body forms)
  "Evaluate FORMS over and over again, up to a predefined maximum
number of times, called the upper bound, or ceiling, of the loop.

From the description in GEB, you could think that he means that some
arbitrary value between 0 and the upper bound is chosen, but in fact
he's just allowing returns from the block."
  (let ((again (gensym))
        (end (gensym))
        (upper-bound (gensym)))
    `(block ,block-name
       (let ((,i 0)
             (,upper-bound ,upper-bound-form))
         (tagbody
            ,again
            (when (>= ,i ,upper-bound)
              (go ,end))
            ,@forms
            (incf ,i)
            (go ,again)
            ,end)))))

(defvar *block-vars-blacklist*
  '(output)
  "A list of names that should not be block variable names.")

(defmacro with-non-block-vars (list &body forms)
  "Evaluate forms with the names in LIST added to the block variable
names blacklist."
  `(let ((*block-vars-blacklist* (append ,list *block-vars-blacklist*)))
     ,@forms))

(defvar *macro-names* '()
  "A list of well-known macro names.")

(defmacro defmac (name (&rest lambda-list) &body forms)
  "Define a BlooP macro."
  (pushnew name *macro-names*)
  `(progn
     (defmacro ,name (,@lambda-list)
       ,@forms)))

(defvar *proc-names*
  '()
  "A list of well-known procedure names.")

(defmacro defprim (name (&rest lambda-list) &body forms)
  "Define a BlooP primitive procedure."
  (pushnew name *proc-names*)
  `(progn
     ,@(when forms
         `((defun ,name (,@lambda-list)
             ,@forms)))
     ',name))

(defun extract-block-vars (forms)
  "Return the set of block variable names extracted from FORMS.

See also EXTRACT-BLOCK-VARS-IN-FORM."
  (mapcan #'extract-block-vars-in-form forms))

(defun extract-block-vars-in-form (form)
  "Return the set of block variable names extracted from FORM.

These are names that are being assigned to via SETQ, with the
exception of names in *BLOCK-VARS-BLACKLIST*."
  (if (atom form)
      '()
      (case (car form)
        (setq
         (nconc
          (if (member (cadr form) *block-vars-blacklist*)
              '()
              (list (cadr form)))
          (extract-block-vars-in-form (caddr form))))
        (bounded-loop
            (destructuring-bind ((var upper-bound-form &optional block-name) &body forms)
                (cdr form)
              (declare (ignore var block-name))
              (nconc (extract-block-vars-in-form upper-bound-form)
                     (extract-block-vars forms))))
        (block
            (extract-block-vars (cddr form)))
        (return-from
         (extract-block-vars-in-form (caddr form)))
        (t
         (cond ((member (car form) *macro-names*)
                (extract-block-vars-in-form (macroexpand-1 form)))
               ((member (car form) *proc-names*)
                (mapcan #'extract-block-vars-in-form (cdr form)))
               (t
                (error "Unexpected operator in form ~S." form)))))))

(defmacro defproc (name (&rest lambda-list) &body forms)
  "Define a BlooP procedure."
  (assert (null (intersection lambda-list-keywords lambda-list)) (lambda-list)
          "Only required parameters are allowed in lambda list.")
  (let ((block-vars (delete-duplicates
                     (with-non-block-vars lambda-list
                       (extract-block-vars forms)))))
    (pushnew name *proc-names*)
    `(progn
       (defun ,name (,@lambda-list)
         (let ((output 0)
               ,@block-vars)
           ,@forms
           output)))))