[ginseng-cvs] CVS ginseng/src
wchunye
wchunye at common-lisp.net
Sat Sep 11 15:50:42 UTC 2010
Update of /project/ginseng/cvsroot/ginseng/src
In directory cl-net:/tmp/cvs-serv24595/src
Modified Files:
my-utils.lisp package.lisp pattern-match.lisp
Log Message:
update documents and examples
--- /project/ginseng/cvsroot/ginseng/src/my-utils.lisp 2010/08/09 12:27:25 1.1
+++ /project/ginseng/cvsroot/ginseng/src/my-utils.lisp 2010/09/11 15:50:42 1.2
@@ -14,12 +14,60 @@
`(setq it ,s))
body)
it)))
+(defmacro aand (&body body)
+ `(let ((it (and (boundp 'it) it)))
+ (and
+ ,@(mapcar #'(lambda (s)
+ `(setq it ,s))
+ body))))
(let ((output *standard-output*))
(defun my-debug (&rest args)
(format output "~&WCY-DEBUG:")
(apply #'format output args)))
-
-(defun make-unique-id ()
- (hunchentoot::md5-hex
- (hunchentoot::create-random-string 10 36)))
\ No newline at end of file
+(defun default-main()
+ "
+<html>
+<head>
+<title> GINSENG DEFAULT ACTION FOR DEBUG.</title>
+</head>
+<body>
+<h1> DEFAULT ACTION IS NOT DEFINED </h1>
+</body>
+")
+
+(defvar *last-request* nil)
+(defvar *last-reply* nil)
+(defvar *last-session* nil)
+(defvar *last-app-name* nil)
+(defvar *last-k* nil)
+(defvar *last-environment* nil)
+(defvar *last-acceptor* nil)
+(defmacro with-last-environment (&body body)
+ `(let* ((hunchentoot::*acceptor* *last-acceptor*)
+ (hunchentoot::*request* *last-request*)
+ (hunchentoot:*reply* *last-request*)
+ (hunchentoot::*acceptor* (hunchentoot:request-acceptor ginseng::*last-request*))
+ (hunchentoot::*session* *last-session*)
+ (*ginseng-app-name* *last-app-name*)
+ (*environment* *last-environment*)
+ (*k* *last-k*)
+ )
+ , at body))
+(defun save-last-environment ()
+ (setq *last-acceptor* hunchentoot::*acceptor*
+ *last-request* hunchentoot:*request*
+ *last-reply* hunchentoot:*reply*
+ *last-session* hunchentoot:*session*
+ *last-app-name* *ginseng-app-name*
+ *last-k* *k*
+ *last-environment* *environment*
+ ))
+(defun clear-package(package)
+ (when (not (packagep package))
+ (setq package (find-package package)))
+ (dolist (s (let (r)
+ (do-symbols (var package)
+ (push var r)) r))
+ (unintern s package)))
+
\ No newline at end of file
--- /project/ginseng/cvsroot/ginseng/src/package.lisp 2010/08/11 12:02:40 1.2
+++ /project/ginseng/cvsroot/ginseng/src/package.lisp 2010/09/11 15:50:42 1.3
@@ -1,25 +1,24 @@
(in-package :cl-user)
+(defpackage :pattern-match
+ (:use :common-lisp)
+ (:export :match :match-values))
(defpackage :ginseng
- (:use :cl :iterate :yaclml)
- (:export :my-debug :aprogn :it :start-server :stop-server
+ (:use :cl
+ :iterate
+ :pattern-match
+ :yaclml)
+ (:export :my-debug :aprogn :awhen :it
+ :start-hunchentoot :stop-hunchentoot
+ :start-ginseng :stop-ginseng
:dynamic-url
:relative-url-to-app
:invoke-next-action
- :make-callback-factory
- :create-callback
- :apply-callbacks
+ :bindf
+ :with-call-back
+ :standard-page
:env-var
:with-rebinds
- )
- (:import-from :hunchentoot
- :*dispatch-table*
- :create-prefix-dispatcher
- :start
- :stop
- :acceptor
- :script-name*
- :*request*
- :session-value
- :get-parameters*
- :post-parameters*
- ))
+ :with-env-vars
+ :with-session-vars
+ ))
+
--- /project/ginseng/cvsroot/ginseng/src/pattern-match.lisp 2010/08/09 12:27:25 1.1
+++ /project/ginseng/cvsroot/ginseng/src/pattern-match.lisp 2010/09/11 15:50:42 1.2
@@ -1,44 +1,150 @@
-(in-package :ginseng)
-(defun generate-code (pattern in body)
- (cond
- ((null pattern)
- `(if (null ,in)
- ,body))
- ((consp pattern)
- (let ((next-car (gensym))
- (next-cdr (gensym)))
-
- `(if (consp ,in)
- (let ((,next-car (car ,in))
- (,next-cdr (cdr ,in)))
- (declare (ignorable ,next-car ,next-cdr))
- ,(generate-code (car pattern) next-car
- (generate-code (cdr pattern) next-cdr body))))))
- ((symbolp pattern)
- `(let ((,pattern ,in))
- (declare (ignorable ,pattern))
- ,body)
- )))
-(defmacro p(pattern)
- (let ((input (gensym)))
- `#'(lambda (,input)
- ,(generate-code pattern input t))))
-(defun match-helper (expr test-body)
- (if (null test-body) nil
- (let ((ok (gensym))
- (v (gensym))
- (tmp-args (gensym)))
- `(multiple-value-bind (,ok ,v)
- (funcall
- #'(lambda (,tmp-args)
- ,(generate-code (caar test-body)
- tmp-args (append (list 'values t) (cdar test-body))))
- ,expr)
- (if ,ok
- ,v
- ,(match-helper expr (cdr test-body)))))))
-(defmacro match (expr test-body)
- (let ((expr-v (gensym)))
- `(let ((,expr-v ,expr))
- ,(match-helper expr-v test-body))))
-
+(in-package :pattern-match)
+(defvar *bindings* nil)
+(defun generate-code-null (pattern arg body-cont)
+ (if (null pattern)
+ #'(lambda ()
+ `(if 'generate-code-null
+ (if (null ,arg) ,(funcall body-cont))))))
+(defun generate-code-ignore (pattern arg body-cont)
+ (declare (ignore arg))
+ (if (and (symbolp pattern)
+ (string= (symbol-name pattern) "_"))
+ #'(lambda ()
+ `(if 'generate-code-ignore
+ (progn ,(funcall body-cont))))))
+(defun generate-code-T (pattern arg body-cont)
+ (if (eq pattern T)
+ #'(lambda ()
+ `(if 'generate-code-T
+ (if (eq ,arg T) ,(funcall body-cont))))))
+(defun generate-code-string (pattern arg body-cont)
+ (if (stringp pattern)
+ #'(lambda ()
+ `(if 'generate-code-string
+ (if (string= ,arg ,pattern) ,(funcall body-cont))))))
+(defun generate-code-keywords (pattern arg body-cont)
+ (if (keywordp pattern)
+ #'(lambda ()
+ `(if 'generate-code-keywords
+ (if (eq ,pattern ,arg) ,(funcall body-cont))))))
+(defun generate-code-quote (pattern arg body-cont)
+ (if (and (listp pattern)
+ (eq (car pattern) 'cl:quote))
+ #'(lambda ()
+ `(if 'generate-code-quote
+ (if (equal ',(cadr pattern) ,arg) ,(funcall body-cont))))))
+(defun generate-code-symbol (pattern arg body-cont)
+ (if (symbolp pattern)
+ #'(lambda ()
+ (let ((is-bound (find pattern *bindings*)))
+ (if is-bound
+ `(if 'generate-code-bound-symbol
+ (if (equal ,pattern ,arg)
+ ,(funcall body-cont)))
+ (let ((*bindings* (cons pattern *bindings*)))
+ `(if 'generate-code-unbound-symbol
+ (let ((,pattern ,arg))
+ (declare (ignorable ,pattern))
+ ,(funcall body-cont)))))))))
+(defun generate-code-vector (pattern arg body-cont)
+ (if (vectorp pattern)
+ (let ((len (length pattern))
+ (vars (map 'vector #'(lambda (v) (declare (ignore v)) (gensym "VEC")) pattern))
+ (code-cont body-cont))
+ (loop
+ for i downfrom (1- len) to 0
+ do (progn
+ (setf code-cont
+ (let ((code-cont code-cont)
+ (i i))
+ #'(lambda ()
+ `(let ((,(aref vars i) (aref ,arg ,i)))
+ ,(funcall (generate-code (aref pattern i) (aref vars i) code-cont))))))))
+ #'(lambda ()
+ `(if 'generate-code-vector
+ (if (and (vectorp ,arg)
+ (= (length ,arg) ,len))
+ ,(funcall code-cont)))))))
+(defun generate-code-consp (pattern arg body-cont)
+ (if (consp pattern)
+ (let ((next-car (gensym))
+ (next-cdr (gensym)))
+ #'(lambda ()
+ `(if 'generate-code-consp
+ (if (consp ,arg)
+ (let ((,next-car (car ,arg))
+ (,next-cdr (cdr ,arg)))
+ (declare (ignorable ,next-car ,next-cdr))
+ ,(let ((cdr-code-body-cont (generate-code (cdr pattern) next-cdr body-cont)))
+ (funcall (generate-code (car pattern) next-car cdr-code-body-cont))))))))))
+(defun generate-code-default (pattern arg body-cont)
+ #'(lambda ()
+ `(if 'generate-code-default
+ (if (equal ,pattern ,arg)
+ ,(funcall body-cont)))))
+(defparameter *generate-code-functions*
+ (list #'generate-code-null
+ #'generate-code-ignore
+ #'generate-code-T
+ #'generate-code-string
+ #'generate-code-keywords
+ #'generate-code-quote
+ #'generate-code-symbol
+ #'generate-code-vector
+ #'generate-code-consp
+ #'generate-code-default
+ ))
+(defun generate-code (pattern arg cont)
+ "ARG is the formal argument of the generated function. GENERATE-CODE
+returns a generated function which matchs the PATTERN against ARG. If
+match, the generated function evaluated the BODY and return the
+result. "
+ (let (next-cont)
+ (dolist (f *generate-code-functions*)
+ (setf next-cont
+ (or next-cont (funcall f pattern arg cont))))
+ (assert next-cont)
+ next-cont))
+
+(defun match-helper (expr pattern-body)
+ "MATCH evaluate first expression and EXPR is the symbol whose value is the
+results of the evaluation. PATTERN-BODY is a list of patterns as follows
+ ( (PATTERN_1 BODY_1)
+ (PATTERN_2 BODY_2)
+ ....
+ )
+
+"
+ (if (null pattern-body) nil
+ (let ((ok (gensym))
+ (v (gensym))
+ (tmp-args (gensym))
+ (pattern (caar pattern-body))
+ (body (cdar pattern-body))
+ guard)
+ (when (and (listp (car body)) (eq (caar body) :guard))
+ ;; if the first element of body is :guard, then the next element is
+ ;; the GUARD expression.
+ (setq guard (cadr (pop body))))
+ `(multiple-value-bind (,v ,ok) ;; if pattern is matched, OK is t, V is
+ ;; the form which is ready for
+ ;; evaluating.
+ (funcall
+ #'(lambda (,tmp-args) ;; this function return two values which is catched by OK and V.
+ ,(let ((*bindings* nil))
+ (funcall
+ (generate-code pattern tmp-args #'(lambda ()
+ (if guard
+ `(when ,guard (values (progn , at body) t))
+ `(values (progn , at body) t)))))))
+ ,expr)
+ (if ,ok ,v
+ ,(match-helper expr (cdr pattern-body)))))))
+(defmacro match (expr &rest test-body)
+ (let ((expr-v (gensym)))
+ `(let ((,expr-v ,expr))
+ ,(match-helper expr-v test-body))))
+(defmacro match-values (multi-values-expr &rest test-body)
+ (let ((expr-v (gensym)))
+ `(let ((,expr-v (multiple-value-list ,multi-values-expr)))
+ ,(match-helper expr-v test-body))))
\ No newline at end of file
More information about the ginseng-cvs
mailing list