From 7b1d40a68402e0ce3c2732489c38ac996b57c72c Mon Sep 17 00:00:00 2001
From: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
Date: Sun, 13 Apr 2014 20:57:27 +0100
Subject: [PATCH] import of pattern-specializer examples

---
 examples/code-walker.lisp     | 245 ++++++++++++++++++++++++++++++++++
 examples/lambda-calculus.lisp | 134 +++++++++++++++++++
 examples/test.lisp            |  63 +++++++++
 3 files changed, 442 insertions(+)
 create mode 100644 examples/code-walker.lisp
 create mode 100644 examples/lambda-calculus.lisp
 create mode 100644 examples/test.lisp

diff --git a/examples/code-walker.lisp b/examples/code-walker.lisp
new file mode 100644
index 0000000..4d81d2c
--- /dev/null
+++ b/examples/code-walker.lisp
@@ -0,0 +1,245 @@
+;;;; code-walker.lisp --- TODO.
+;;;;
+;;;; Copyright (C) 2013, 2014 Christophe Rhodes
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Christophe Rhodes
+
+;;;; Partially based on TODO
+
+(cl:defpackage #:pattern-specializer.examples.code-walker
+  (:use
+   #:cl
+   #:pattern-specializer)
+
+  (:import-from #:specializable
+   #:cons-generic-function)
+
+  (:import-from #:optima
+   #:guard))
+
+(cl:in-package #:pattern-specializer.examples.code-walker)
+
+(defclass binding ()
+  ((used :initform nil :accessor used)))
+
+(defun make-env (bindings env)
+  (append bindings env))
+(defun find-binding (env var)
+  (cdr (assoc var env)))
+
+(defun bindings-from-ll (ll)
+  (mapcar (lambda (n) (cons n (make-instance 'binding))) ll))
+
+(define-condition walker-warning (warning)
+  ((env :initarg :env :reader env)
+   (call-stack :initarg :call-stack :reader call-stack)))
+(define-condition unused-variable (walker-warning)
+  ((name :initarg :name :reader name)))
+(define-condition unbound-variable-referenced (walker-warning)
+  ((name :initarg :name :reader name)))
+
+(defmacro with-checked-bindings ((bindings env call-stack) &body body)
+  `(let* ((bindings ,bindings)
+          (,env (make-env bindings ,env)))
+     ,@body
+     (dolist (binding bindings)
+       (unless (used (cdr binding))
+         (warn 'unused-variable :name (car binding)
+               :env ,env :call-stack ,call-stack)))))
+
+;;; walk/cons
+
+(defgeneric walk/cons (form env vars)
+  (:generic-function-class cons-generic-function))
+
+(defmethod walk/cons ((expr t) env call-stack)
+  nil)
+
+(defmethod walk/cons ((expr cons) env call-stack)
+  (let ((cs (cons expr call-stack)))
+    (when (consp (car expr))
+      (walk/cons (car expr) env cs))
+    (dolist (e (cdr expr))
+      (walk/cons e env (cons e cs)))))
+
+(defmethod walk/cons ((expr symbol) env call-stack)
+  (if (constantp expr)
+      nil
+      (let ((binding (find-binding env expr)))
+        (if binding
+            (setf (used binding) t)
+            (warn 'unbound-variable-referenced :name expr
+                  :env env :call-stack call-stack)))))
+
+(defmethod walk/cons ((expr (cons lambda)) env call-stack)
+  (let ((lambda-list (cadr expr))
+        (body (cddr expr)))
+    (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+      (dolist (form body)
+        (walk/cons form env (cons form call-stack))))))
+
+(defmethod walk/cons ((expr (cons multiple-value-bind)) env call-stack)
+  (let ((lambda-list (cadr expr))
+        (value-form (caddr expr))
+        (body (cdddr expr)))
+    (walk/cons value-form env (cons value-form call-stack))
+    (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+      (dolist (form body)
+        (walk/cons form env (cons form call-stack))))))
+
+(defmethod walk/cons ((expr (cons let)) env call-stack)
+  (flet ((let-binding (x)
+           (walk/cons (cadr x) env (cons (cadr x) call-stack))
+           (cons (car x) (make-instance 'binding))))
+    (with-checked-bindings ((mapcar #'let-binding (cadr expr)) env call-stack)
+      (dolist (form (cddr expr))
+        (walk/cons form env (cons form call-stack))))))
+
+;;; walk/pattern
+
+(defun walk-binding-form-body (bindings body env call-stack)
+  (with-checked-bindings (bindings env call-stack)
+    (dolist (form body)
+      (walk/pattern form env (cons form call-stack)))))
+
+(defgeneric walk/pattern (form env vars)
+  (:generic-function-class pattern-generic-function))
+
+(defmethod walk/pattern ((expr t) env call-stack)
+  nil)
+
+(defmethod walk/pattern ((expr cons) env call-stack)
+  (let ((cs (cons expr call-stack)))
+    (when (consp (car expr))
+      (walk/pattern (car expr) env cs))
+    (dolist (e (cdr expr))
+      (walk/pattern e env (cons e cs)))))
+
+(defmethod walk/pattern ((expr (pattern (type (and symbol (not (satisfies constantp)))))) env call-stack)
+  (let ((binding (find-binding env expr)))
+    (if binding
+        (setf (used binding) t)
+        (warn 'unbound-variable-referenced :name expr
+              :env env :call-stack call-stack))))
+
+(defmethod walk/pattern ((expr (pattern (list* 'lambda lambda-list body))) env call-stack)
+  (walk-binding-form-body
+   (bindings-from-ll lambda-list) body env call-stack))
+
+(defmethod walk/pattern ((expr (pattern (list* 'multiple-value-bind lambda-list value-form body))) env call-stack)
+  (walk/pattern value-form env (cons value-form call-stack))
+  (walk-binding-form-body
+   (bindings-from-ll lambda-list) body env call-stack))
+
+(defmethod walk/pattern ((expr (pattern (list* 'let bindings body))) env call-stack)
+  (flet ((let-binding (binding)
+           (destructuring-bind (name value) binding
+             (walk/pattern value env (cons value call-stack))
+             (cons name (make-instance 'binding)))))
+    (walk-binding-form-body
+     (mapcar #'let-binding bindings) body env call-stack)))
+
+;;; walk/case
+
+(defun walk/case (expr env call-stack)
+  (typecase expr
+    (symbol
+     (if (constantp expr)
+         nil
+         (let ((binding (find-binding env expr)))
+           (if binding
+               (setf (used binding) t)
+               (warn 'unbound-variable-referenced :name expr
+                     :env env :call-stack call-stack)))))
+    ((cons (eql lambda))
+     (let ((lambda-list (cadr expr))
+           (body (cddr expr)))
+       (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+         (dolist (form body)
+           (walk/case form env (cons form call-stack))))))
+    ((cons (eql multiple-value-bind))
+     (let ((lambda-list (cadr expr))
+           (value-form (caddr expr))
+           (body (cdddr expr)))
+       (walk/case value-form env (cons value-form call-stack))
+       (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+         (dolist (form body)
+           (walk/case form env (cons form call-stack))))))
+    ((cons (eql macrolet)))
+    ((cons (eql flet)))
+    ((cons (eql labels)))
+    ((cons (eql symbol-macrolet)))
+    ((cons (eql if)))
+    ((cons (eql progn)))
+    ((cons (eql tagbody)))
+    ((cons (eql return-from)))
+    ((cons (eql multiple-value-call)))
+    ((cons (eql block)))
+    ((cons (eql catch)))
+    ((cons (eql throw)))
+    ((cons (eql let))
+     (with-checked-bindings ((mapcar (lambda (x) (walk/case (cadr x) env (cons (cadr x) call-stack)) (cons (car x) (make-instance 'binding))) (cadr expr)) env call-stack)
+       (dolist (form (cddr expr))
+         (walk/case form env (cons form call-stack)))))
+    (cons
+     (let ((cs (cons expr call-stack)))
+       (when (consp (car expr))
+         (walk/case (car expr) env cs))
+       (dolist (e (cdr expr))
+         (walk/case e env (cons e cs)))))
+    (t)))
+
+;;; walk/meth
+
+(defgeneric walk/meth (expr env call-stack))
+
+(defmethod walk/meth ((expr symbol) env call-stack)
+  (if (constantp expr)
+      nil
+      (let ((binding (find-binding env expr)))
+        (if binding
+            (setf (used binding) t)
+            (warn 'unbound-variable-referenced :name expr
+                  :env env :call-stack call-stack)))))
+(defmethod walk/meth ((expr t) env call-stack)
+  nil)
+
+(defmethod walk/meth ((expr cons) env call-stack)
+  (typecase expr
+    ((cons (eql lambda))
+     (let ((lambda-list (cadr expr))
+           (body (cddr expr)))
+       (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+         (dolist (form body)
+           (walk/meth form env (cons form call-stack))))))
+    ((cons (eql multiple-value-bind))
+     (let ((lambda-list (cadr expr))
+           (value-form (caddr expr))
+           (body (cdddr expr)))
+       (walk/meth value-form env (cons value-form call-stack))
+       (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+         (dolist (form body)
+           (walk/meth form env (cons form call-stack))))))
+    ((cons (eql macrolet)))
+    ((cons (eql flet)))
+    ((cons (eql labels)))
+    ((cons (eql symbol-macrolet)))
+    ((cons (eql if)))
+    ((cons (eql progn)))
+    ((cons (eql tagbody)))
+    ((cons (eql return-from)))
+    ((cons (eql multiple-value-call)))
+    ((cons (eql block)))
+    ((cons (eql catch)))
+    ((cons (eql throw)))
+    ((cons (eql let))
+     (with-checked-bindings ((mapcar (lambda (x) (walk/meth (cadr x) env (cons (cadr x) call-stack)) (cons (car x) (make-instance 'binding))) (cadr expr)) env call-stack)
+       (dolist (form (cddr expr))
+         (walk/meth form env (cons form call-stack)))))
+    (t
+     (let ((cs (cons expr call-stack)))
+       (when (consp (car expr))
+         (walk/meth (car expr) env cs))
+       (dolist (e (cdr expr))
+         (walk/meth e env (cons e cs)))))))
diff --git a/examples/lambda-calculus.lisp b/examples/lambda-calculus.lisp
new file mode 100644
index 0000000..2073db0
--- /dev/null
+++ b/examples/lambda-calculus.lisp
@@ -0,0 +1,134 @@
+;;;; lambda-calculus.lisp --- Untyped lambda calculus based on pattern specializers.
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.DE>
+
+;;;; Partially based on idea from
+;;;;
+;;;; [1] Benjamin C. Pierce (2002): Types and Programming languages
+
+(cl:defpackage #:pattern-specializer.examples.lambda-calculus
+  (:use
+   #:cl
+   #:pattern-specializer)
+
+  (:shadow
+   #:abs)
+
+  (:import-from #:optima
+   #:guard))
+
+(cl:in-package #:pattern-specializer.examples.lambda-calculus)
+
+;;; Syntax
+;;;
+;;;        ,- app   ,- const
+;;;       /        /
+;;; term ---- val ---- abs
+;;;       \
+;;;        `- var
+
+(defstruct term) ; abstract
+
+(defstruct (val (:include term))) ; abstract
+
+(defstruct (const (:include val) (:constructor make-const (value)))
+  (value nil))  ; TODO val?
+
+(defstruct (var (:include term) (:constructor make-var (name)))
+  (name nil :type symbol))
+
+(defstruct (abs (:include val) (:constructor make-abs (var body)))
+  (var nil :type var)
+  (body nil :type term))
+
+(defstruct (app (:include term) (:constructor make-app (fun arg)))
+  (fun nil :type term)
+  (arg nil :type val))
+
+;;; Parse
+
+(defgeneric parse (form)
+  (:generic-function-class pattern-generic-function))
+
+(defmethod parse ((form integer))
+  (make-const form))
+
+(defmethod parse ((form symbol))
+  (make-var form))
+
+(defmethod parse ((form (pattern (list 'λ (guard name (symbolp name)) body))))
+  (make-abs (parse name) (parse body)))
+
+(defmethod parse ((form (pattern (list func arg))))
+  (make-app (parse func) (parse arg)))
+
+;;; Substitution
+
+(defgeneric substitute1 (term var val))
+
+(defmethod substitute1 ((term val) (var var) (val val))
+  term)
+
+;; [1 Page 69]
+(defmethod substitute1 ((term var) (var var) (val val))
+  (if (equalp term var) val term))
+
+;; [1 Page 69]
+(defmethod substitute1 ((term abs) (var var) (val val))
+  ;; TODO capture
+  (make-abs (abs-var term) (substitute1 (abs-body term) var val)))
+
+;; [1 Page 69]
+(defmethod substitute1 ((term app) (var var) (val val))
+  (make-app (substitute1 (app-fun term) var val)
+            (substitute1 (app-arg term) var val)))
+
+;;; Evaluation
+
+(defgeneric eval1 (term)
+  (:generic-function-class pattern-generic-function))
+
+(defmethod eval1 ((term val))
+  term)
+
+;; Reduce function to value
+;;
+;;      t_1 -> t_1'
+;; ---------------------
+;;  t_1 t_2 -> t_1' t_2
+;;
+;; [1 Page 72; Figure 5.3]
+(defmethod eval1 ((term (pattern (app fun arg))))
+  (eval1 (make-app (eval1 fun) arg)))
+
+;; Reduce argument to value
+;;
+;;      t_2 -> t_2'
+;; ---------------------
+;;  v_1 t_2 -> v_1 t_2'
+;;
+;; [1 Page 72; Figure 5.3]
+(defmethod eval1 ((term (pattern (app (fun (and fun (val))) arg))))
+  (eval1 (make-app fun (eval1 arg))))
+
+;; Application
+;;
+;; (λx.t_{12}) v_2 -> [x -> v_2] t_{12}
+;;
+;; [1 Page 72; Figure 5.3]
+(defmethod eval1 ((term (pattern (app (fun (abs var body)) (arg (and arg (val)))))))
+  (let ((arg-value (eval1 arg)))
+    (eval1 (substitute1 body var arg-value))))
+
+;;; Test
+
+(eval1 (make-const 1))
+
+(eval1 (make-abs (make-var 'x) (make-const 1)))
+
+(eval1 (make-app (make-abs (make-var 'x) (make-var 'x)) (make-const 1)))
+;; => #S(CONST :VALUE 1)
+
+(eval1 (parse '(((λ z (λ y z)) 5) 6)))
diff --git a/examples/test.lisp b/examples/test.lisp
new file mode 100644
index 0000000..36847ce
--- /dev/null
+++ b/examples/test.lisp
@@ -0,0 +1,63 @@
+;;;; test.lisp ---
+;;;;
+;;;; Copyright (C) 2014 Jan Moringen
+;;;;
+;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
+
+(cl:in-package #:cl-user)
+
+(defgeneric test-match/1 (thing &key &allow-other-keys)
+  (:generic-function-class pattern-specializer:pattern-generic-function))
+
+(defmethod test-match/1 ((thing (pattern-specializer:pattern (cons n "bla"))))
+  (list (list :cons-n-string-bla n)
+        (when (next-method-p)
+          (call-next-method))))
+
+(defmethod test-match/1 ((thing (pattern-specializer:pattern (cons n "bli"))))
+  (list (list :cons-n-string-bli n)
+        (when (next-method-p)
+          (call-next-method))))
+
+(defmethod test-match/1 :around ((thing (pattern-specializer:pattern (cons 1 "bli"))))
+  (list :around-cons-1-string-bli
+        (when (next-method-p)
+          (call-next-method))))
+
+(defmethod test-match/1 ((thing (pattern-specializer:pattern (cons 1 "bli"))))
+  :cons-1-string-bli)
+
+(defmethod test-match/1 ((thing (pattern-specializer:pattern (cons n m))))
+  (list :cons-n-m n m))
+
+(test-match/1 (cons 5 "bla"))
+(test-match/1 (cons 1 "bli"))
+(test-match/1 (cons 1 "blu"))
+
+(defgeneric test-match/2 (thing1 thing2 &key foo)
+  (:generic-function-class pattern-specializer:pattern-generic-function))
+
+(defmethod test-match/2 ((thing1 (pattern-specializer:pattern (cons 1 "bla")))
+                         (thing2 (pattern-specializer:pattern (cons 2 "bla")))
+                         &key foo)
+  :cons-1-string-bla-cons-2-string-bla)
+
+(test-match/2 (cons 1 "bla") (cons 2 "bla"))
+(test-match/2 (cons 1 "bli") (cons 2 "bla"))
+(test-match/2 (cons 1 "blu") (cons 2 "bla"))
+
+
+
+(defgeneric test-match/3 (thing1 thing2 thing3
+                          &rest bla)
+  (:generic-function-class pattern-specializer:pattern-generic-function))
+
+(defmethod test-match/3 ((thing1 (pattern-specializer:pattern (cons 1 my-var)))
+                         (thing2 t)
+                         (thing3 (pattern-specializer:pattern (cons 3 "bla")))
+                         &rest bla)
+  (list thing1 thing2 :cons-3-string-bla my-var bla))
+
+(test-match/3 (cons 1 "bla") :bar (cons 3 "bla"))
+(test-match/3 (cons 1 "blu") :bar (cons 3 "bla"))
+(test-match/3 (cons 1 "bli") (cons 2 "bla"))
-- 
2.30.2