Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 243 lines (196 sloc) 7.556 kb
3c1ccf65 »
2009-03-21 first commit GIT not darcs
1 ;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; -*-
2 ;; Sun Nov 4 17:19:54 2007 by Nick Allen <nallen05@gmail.com>
3 ;; bpm.lisp
4
5 ;; this file contains all the code necessary for `bpm' to work.
6
7 ;; the file `bpm-prettify.lisp'populates the parameter
8 ;; *PRETTIFY-OUTPUT-TRANSFORMATIONS* with some functions to make the
9 ;; generated code smaller/cleaner/faster but its not really necessary.
10
11 ;; the tests in `bpm-test.lisp' should pass with or without loading
12 ;; `bpm-prettify.lisp'.
13
14 ;; see DOC/BPM.HTML for a description of the API
15
16 ;; Copyright (c) 2007, Nick Allen
17 ;; All rights reserved.
18
19 ;; Redistribution and use in source and binary forms, with or without
20 ;; modification, are permitted provided that the following conditions are met:
21 ;; * Redistributions of source code must retain the above copyright
22 ;; notice, this list of conditions and the following disclaimer.
23 ;; * Redistributions in binary form must reproduce the above copyright
24 ;; notice, this list of conditions and the following disclaimer in the
25 ;; documentation and/or other materials provided with the distribution.
26 ;; * Neither the name of the <organization> nor the
27 ;; names of its contributors may be used to endorse or promote products
28 ;; derived from this software without specific prior written permission.
29
30 ;; THIS SOFTWARE IS PROVIDED BY <copyright holder> ``AS IS'' AND ANY
31 ;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
32 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
33 ;; DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY
34 ;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
35 ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
36 ;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
37 ;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
38 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
39 ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
40
41 (in-package :cl-user)
42
43 (defpackage :bpm
44 (:use :cl)
45 (:export ;; arrow syntax
46 #:-->
47 #:->
48
49 ;; MATCH macro
50 #:match
51
52 ;; DEF!/DEF macros
53 #:def!
54 #:def
55
56 ;; WHERE/WHERE-NOT clauses in MATCH and DEF!/DEF
57 #:where
58 #:where-not
59
60 ;;BPM-LAMBDA macro
61 #:bpm-lambda
62
63 ;; CREATE-BPM-COMPILER function
64 #:create-bpm-compiler
65
66 ;; tweaking logic var syntax
67 #:*logic-var-prefix-char*
68 #:*logic-var-pred*
69 #:*logic-var-wildcard-pred*
70
71 ;; other BMP compiler vars
72 #:*destructure-simple-vectors-p*
73 #:*logic-var-equality-test*))
74
75 (in-package :bpm)
76
77 ;arrow syntax
78 (defconstant --> '-->)
79 (defconstant -> '->)
80
81 ;MATCH
82
83 (defmacro match (form &body clauses)
84 (let ((g (gensym)))
85 `(let ((,g ,form))
86 (funcall (or ,@(mapcar (lambda (c)
87 (destructuring-bind (pat . cbody) c
88 `(funcall (.bpm-lambda* ,pat ,@cbody) ,g)))
89 clauses)
90 (constantly nil))))))
91
92 (defmacro .bpm-lambda* (patt &body body)
93 (labels ((rfn (b)
94 (destructuring-bind (wc? . r) b
95 (if (and (listp wc?)
96 (eq (first wc?) 'where))
97 `(when ,(second wc?)
98 ,(rfn r))
99 (if (and (listp wc?)
100 (eq (first wc?) 'where-not))
101 `(unless ,(second wc?)
102 ,(rfn r))
103 `(lambda () ,@b))))))
104 `(bpm-lambda ,patt ,(rfn body))))
105
106 ;DEF!/DEF macros
107
108 (defmacro def! (name patt &body body)
109 `(progn
110 (setf (get ',name 'rules)
111 (list (.bpm-lambda* ,patt ,@body)))
112 (defun ,name (sexp)
113 (funcall (or (some (lambda (f) (funcall f sexp))
114 (get ',name 'rules))
115 (constantly nil))))))
116
117 (defmacro def (name patt &body body)
118 `(progn (setf (get ',name 'rules)
119 (append (get ',name 'rules)
120 (list (.bpm-lambda* ,patt ,@body))))
121 ',name))
122
123 ;WHERE/WHERE-NOT symbols
124
125 (defun where (test)
126 (error "the clause ~S has escaped from inside a bpm form! this symbol ~S does not name a function or a macro: it names a special keyword that only has meaning within the ~S, ~S, or ~S macros."
127 `(where ,test) 'where 'def 'def! 'match))
128
129 (defun where-not (test)
130 (error "the clause ~S has escaped from inside a bpm form! this symbol ~S does not name a function or a macro: it names a special keyword that only has meaning within the ~S, ~S, or ~S macros."
131 `(where-not ,test) 'where-not 'def 'def! 'match))
132
133 ;BPM-LAMBDA
134
135 (defmacro bpm-lambda (pattern &body body)
136 (funcall (create-bpm-compiler pattern) `(progn ,@body)))
137
138 ;logic var syntax
139
140 (defparameter *logic-var-prefix-char* #\_)
141
142 (defparameter *logic-var-pred*
143 (lambda (xx)
144 (and (symbolp xx)
145 (not (zerop (length (symbol-name xx))))
146 (char= (char (symbol-name xx) 0) *logic-var-prefix-char*))))
147
148 (defparameter *logic-var-wildcard-pred*
149 (lambda (xx)
150 (and (symbolp xx)
151 (= (length (symbol-name xx)) 1)
152 (char= (char (symbol-name xx) 0) *logic-var-prefix-char*))))
153
154 ;other compile vars
155
156 (defparameter *destructure-simple-vectors-p* t)
157
158 (defparameter *logic-var-equality-test* 'eql)
159
160 ;CREATE-BPM-COMPILER
161
162 (defvar *bound*)
163
164 (defvar +match+ '+match+)
165
166 (defun create-bpm-compiler (pattern &optional *bound*)
167 (if (funcall *logic-var-wildcard-pred* pattern)
168 (values (lambda (form)
169 `(lambda (,pattern)
170 (declare (ignore ,pattern))
171 ,form))
172 *bound*)
173 (let ((% (.create-match-template pattern)))
174 (values (lambda (form)
175 (subst form +match+ (.prettify-output %)))
176 *bound*))))
177
178 (defun .create-compiler (pattern)
179 (let ((% (.create-match-template pattern)))
180 (values (lambda (form) (subst form +match+ %))
181 *bound*)))
182
183 (defun .create-match-template (p)
184 (let ((f (gensym)))
185 `(lambda (,f)
186 ,@(if (funcall *logic-var-wildcard-pred* p)
187 `((declare (ignore ,f))))
188 ,(typecase p
189 (null `(if (not ,f)
190 +match+))
191 (atom (cond ((funcall *logic-var-wildcard-pred* p) +match+)
192 ((funcall *logic-var-pred* p) (if (find p *bound*)
193 `(if (,*logic-var-equality-test* ,f ,p)
194 +match+)
195 (progn (push p *bound*)
196 `(let ((,p ,f))
197 +match+))))
198 ((and (simple-vector-p p)
199 *destructure-simple-vectors-p*) (.handle-simple-vector p f))
200 (t `(if (,*logic-var-equality-test* ,f ',p)
201 +match+))))
202 (list (let ((g (gensym))
203 (compiler (.create-compiler (first p))))
204 `(let ((,g ,f))
205 (if (listp ,g)
206 (funcall ,(funcall compiler
207 `(funcall ,(funcall (.create-compiler (rest p))
208 +match+)
209 (rest ,g)))
210 (first ,g))))))))))
211
212 (defun .handle-simple-vector (v form)
213 (let ((g (gensym)))
214 `(let ((,g ,form))
215 (if (simple-vector-p ,g)
216 (if (= (length ,g) ,(length v))
217 ,(.expand-sv-compilers-and-indexes g (.collect-sv-compilers-and-indexes v)))))))
218
219 (defun .expand-sv-compilers-and-indexes (f xx)
220 (if (not xx)
221 +match+
222 (destructuring-bind ((compiler . index) . rest) xx
223 `(funcall ,(funcall compiler (.expand-sv-compilers-and-indexes f rest))
224 (svref ,f ,index)))))
225
226 (defun .collect-sv-compilers-and-indexes (v)
227 (let (xx)
228 (dotimes (n (length v) (nreverse xx))
229 (let ((e (svref v n)))
230 (if (not (funcall *logic-var-wildcard-pred* e))
231 (push (cons (.create-compiler e)
232 n)
233 xx))))))
234
235 (defparameter *prettify-output-transformations* nil)
236
237 (defun .prettify-output (in)
238 (labels ((rfn (x fs)
239 (if (not fs)
240 x
241 (destructuring-bind (f . rest) fs
242 (rfn (funcall (coerce f 'function) x) rest)))))
243 (rfn in *prettify-output-transformations*)))
Something went wrong with that request. Please try again.