Study Hall #1 @bocoup

study-hall-1.lisp

;;;
;;; Study Hall #1
;;; example lisp code, by Eric O'Connor
;;;

;; define a package
(defpackage play
  (:use cl))

;; use the package
(in-package :play)

;; utility functions

(defun quit ()
  (ccl::quit))

;; eval-when :compile-toplevel allows these functions to be available
;; during macro expansion
(eval-when (:compile-toplevel :load-toplevel :execute)

  (defun xor (a b)
    (and (or a b)
	 (not (and a b))))

  (defun flatten (lst)
    (if (consp lst)
	(append (flatten (car lst)) (flatten (cdr lst)))
	(when lst (list lst))))

  (defun match (a b)
    (labels
	((match-inner (a b)
	   (let ((matches (list)))
	     (cond ((and (consp a) (consp b))
		    (let ((cam (match-inner (car a) (car b)))
			  (cdm (match-inner (cdr a) (cdr b))))
		      (if (and (car cam) (car cdm))
			  (progn
			    (setq matches
				  (append matches (cdr cam) (cdr cdm)))
			    (cons t matches))
			  nil)))
		   ((or (xor (consp a) (consp b))
			(xor (null a) (null b)))
		    nil)
		   (t 
		    (if (not (and (null a) (null b)))
			(list t (list a b))
			(list t)))))))
      (cdr (match-inner a b))))
  )

;;; ================================================
;;; unless macro

(defmacro my-unless (test &rest a)
  `(or ,test (progn ,@a)))

;;; ================================================
;;; matchcase macro

(defmacro matchcase (match-item &rest matches)
  ;; gensyms prevent hygiene leaks
  (let ((evaled-item (gensym "item-"))
	(done-symbol (gensym)))
    `(let ((,evaled-item ,match-item))
       (block ,done-symbol
	 ,@(let ((col (list)))
		(dolist
		    (m matches)
		  (let ((gsymbols (flatten (car m)))
			(match-symbol (gensym "match-")))
		    (push `(let ((,match-symbol (match ',(car m) ,evaled-item)))
			     (when ,match-symbol
			       (let
				   (,@(let ((col (list)))
					   (dolist (binding gsymbols)
					     (push `(,binding
						      (cadr (assoc ',binding
								   ,match-symbol)))
						   col))
					   col))
				 ;; catch errors (like try ... finally)
				 (unwind-protect
				      (progn ,@(cdr m))
				   ;; return to (block above
				   (return-from ,done-symbol)))))
			  col)))
		col)))))

;;; ================================================
;;; matchcase usage:

(matchcase '(123 345 678)
	   ((a b c)
	    (format t "abc: ~A, ~A, ~A~%"
		    a b c))
	   ((x (y (z)))
	    (format t "xyz: ~A, ~A, ~A"
		    x y z)))

;; prints => abc: 123, 345, 678
  
(matchcase '(123 (345 (678)))
	   ((a b c)
	    (format t "abc: ~A, ~A, ~A~%"
		    a b c))
	   ((x (y (z)))
	    (format t "xyz: ~A, ~A, ~A"
		    x y z)))

;; prints => xyz: 123, 345, 678

;;; eof