Commit 88189ad0 authored by hayeah via gmail com's avatar hayeah via gmail com

updated asdf system

- and runnable (I hope) example.

darcs-hash:217149f58cb5a1272d73734ab3302fdf6c2b5230
parent 15b0ab05
(in-package :wisp-mvc)
;; (asdf :wispylisp)
;; start aserve
(start :port 2002)
;; easier debug
(net.aserve::debug-on :notrap)
;; html/css/javascript depend on :invert
(setf (readtable-case *readtable*) :invert)
(deform stack-calculator (stack transcript)
;; The fields of the form.
(+ - * / push new-number)
;; The following form is evaluated and the value(s) returned to the caller.
(let ((op (^symbol (find-if-not #'null (list + - * / push)))))
(if push
(list op (cons (parse-integer new-number) stack))
(list op stack)))
;; outputs the html for the form.
(:input :name new-number)
(:input :name push :type 'submit :value 'push) (:br)
(:input :name + :type 'submit :value '+)
(:input :name - :type 'submit
;; '- doesn't output anything because dash is used for the conversion
;; `foo-bar' => `fooBar'.
:value "-")
(:input :name * :type 'submit :value '*)
(:input :name / :type 'submit :value '/)
(:div :id 'stack :style (:border 1px solid $FF0000 :width 200px)
(dolist (number stack)
(html number (:br))))
(:div :id 'transcript :style (:border 1px solid $00FF00 :width 200px)
(dolist (cmd transcript)
(html cmd (:br)))))
#+(or)
(defwethod calculator-loop (&optional stack)
(let* ((op/stack (read-form 'stack-calculator stack))
(op (car op/stack))
(new-stack (cadr op/stack)))
(if (eql op #'push)
;; Wethod is wrapped in with-call/cc, so it's tail-recursive... I think.
(calculator-loop new-stack)
(calculator-loop (cons
(funcall op (first new-stack) (second new-stack))
(nthcdr 2 new-stack))))))
(defwethod calculator-loop ()
(loop
with transcript
for (op stack) =
(read-form 'stack-calculator nil nil) then (read-form 'stack-calculator stack transcript)
do (if (eql op 'push)
(push (list 'push (car stack)) transcript)
(let ((result (funcall (symbol-function op) (second stack) (first stack))))
(push (format nil "~S => ~S"
(list op (second stack) (first stack))
result)
transcript)
(setf stack (cons result (nthcdr 2 stack)))))))
(defurlmap wisp-sys
;; call-from-k takes the string in place of `:k-id' as its (single) argument.
("form-k/:k-id" :handler call-form-k))
(defurlmap calculator
;; maps the url /calc to the wethod calculator-loop
("calc" :wethod calculator-loop))
;; (get-effective-urls 'calculator)
;; ((:wethod (:url "/calc" "^/calc") :dispatch
;; #<standard-generic-function calculator-loop> :discriminators (nil)
;; :wethod-urls (("" "^$"))))
;; (get-effective-urls 'wisp-sys)
;; ((:handler (:url "/form-k/:k-id" "^/form-k/([^/]+)$") :dispatch
;; #<Interpreted Function CALL-FORM-K>))
(attach-urlmap "test" 'calculator)
(attach-urlmap "wisp-sys" 'wisp-sys)
;; now try http://localhost:2002/test/calc
#|
(calculator-loop)
<form action='/wisp-sys/form-k/9' method='post'>
<input name='(stack-calculator new-number)'>
<input name='(stack-calculator push)' type='submit' value='push'>
<br>
<input name='(stack-calculator +)' type='submit' value='+'>
<input name='(stack-calculator -)' type='submit' value='-'>
<input name='(stack-calculator *)' type='submit' value='*'>
<input name='(stack-calculator /)' type='submit' value='/'>
<div id='stack' style='border: 1px solid #FF0000 ;
width: 200px ;'></div>
<div id='transcript' style='border: 1px solid #00FF00 ;
width: 200px ;'></div>
</form>
(let ((*parameters* `(("(stack-calculator push)" . "push")
("(stack-calculator new-number)" . "10"))))
(call-form-k "9"))
<form action='/wisp-sys/form-k/10' method='post'>
<input name='(stack-calculator new-number)'>
<input name='(stack-calculator push)' type='submit' value='push'>
<br>
<input name='(stack-calculator +)' type='submit' value='+'>
<input name='(stack-calculator -)' type='submit' value='-'>
<input name='(stack-calculator *)' type='submit' value='*'>
<input name='(stack-calculator /)' type='submit' value='/'>
<div id='stack' style='border: 1px solid #FF0000 ;
width: 200px ;'>10
<br>
</div>
<div id='transcript' style='border: 1px solid #00FF00 ;
width: 200px ;'>(push 10)
<br>
</div>
</form>
(let ((*parameters* `(("(stack-calculator push)" . "push")
("(stack-calculator new-number)" . "20"))))
(call-form-k "10"))
<form action='/wisp-sys/form-k/12' method='post'>
<input name='(stack-calculator new-number)'>
<input name='(stack-calculator push)' type='submit' value='push'>
<br>
<input name='(stack-calculator +)' type='submit' value='+'>
<input name='(stack-calculator -)' type='submit' value='-'>
<input name='(stack-calculator *)' type='submit' value='*'>
<input name='(stack-calculator /)' type='submit' value='/'>
<div id='stack' style='border: 1px solid #FF0000 ;
width: 200px ;'>20
<br>
10
<br>
</div>
<div id='transcript' style='border: 1px solid #00FF00 ;
width: 200px ;'>(push 20)
<br>
(push 20)
<br>
(push 10)
<br>
</div>
</form>
(let ((*parameters* `(("(stack-calculator +)" . "+")
("(stack-calculator new-number)" . "20"))))
(call-form-k "12"))
<form action='/wisp-sys/form-k/13' method='post'>
<input name='(stack-calculator new-number)'>
<input name='(stack-calculator push)' type='submit' value='push'>
<br>
<input name='(stack-calculator +)' type='submit' value='+'>
<input name='(stack-calculator -)' type='submit' value='-'>
<input name='(stack-calculator *)' type='submit' value='*'>
<input name='(stack-calculator /)' type='submit' value='/'>
<div id='stack' style='border: 1px solid #FF0000 ;
width: 200px ;'>30
<br>
</div>
<div id='transcript' style='border: 1px solid #00FF00 ;
width: 200px ;'>(+ 10 20) =&gt; 30
<br>
(push 20)
<br>
(push 20)
<br>
(push 10)
<br>
</div>
</form>
|#
\ No newline at end of file
......@@ -107,9 +107,9 @@
arg-spec))
fn-list))
`(render-view ,',name ,@args))))))
,@body))))
(save-wethod ',name)
',name)))
,@body)))))
(save-wethod ',name)
',name))
......
......@@ -33,7 +33,6 @@
values))
,handler))
(multiple-value-list (list 1))
(defun get-form-value (form-name value)
......
......@@ -22,10 +22,6 @@
;;; Copyright (c) 2006 Howard Yeh
;; All rights reserved.
;;
......
(in-package :wisp-mvc)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *defined-views* (make-hash-table :test #'equal))
(defparameter *html-output-stream* *standard-output*)
......@@ -32,20 +32,22 @@
(defmacro respond-with-html ((stream-name) &body body)
;; TODO put the body in a flet.
`(if *request*
;; if is serving a html request
(no-call/cc
(with-http-response (*request* *entity*)
(with-http-body (*request* *entity*)
;; there really shouldn't be application errors when rendering the output.
;; If error IS signaled, I have no idea how aserve will behave.
(let ((,stream-name (request-reply-stream *request*)))
,@body))))
;; or is debugging in lisp
(let ((,stream-name *standard-output*))
(declare (special ,stream-name))
,@body)))
`(progn
(if *request*
;; if is serving a html request
(no-call/cc
(with-http-response (*request* *entity*)
(with-http-body (*request* *entity*)
;; there really shouldn't be application errors when rendering the output.
;; If error IS signaled, I have no idea how aserve will behave.
(let ((,stream-name (request-reply-stream *request*)))
,@body))))
;; or is debugging in lisp
(let ((,stream-name *standard-output*))
(declare (special ,stream-name))
,@body))
t))
......@@ -91,12 +93,12 @@
(error 'wisp-undefined-view :view-name name))
rest))
(defmacro render-html (&body body)
;; TODO. render-html should output to *standard-io*.
;; respond-with-html should move to the wrapper around defwethod.
(defmacro render-html (&body body)
`(respond-with-html (*html-output-stream*)
(with-foo-output (*html-output-stream*)
(html ,@body))))
(with-foo-output (*html-output-stream*)
(html ,@body))))
(defgeneric render-error (werror))
......@@ -123,6 +125,12 @@
(deftag :template (template-name &other-keys others &body body)
;; the choice of which template to use is static.
;; I can't think of a good way to make this dynamic.
(if (keywordp template-name)
(apply (get-template-fn template-name) (append others body))
(error "No dynamic templating... sorry.")))
(defparameter *wisp-templates* (make-hash-table :test #'eql))
......@@ -137,13 +145,11 @@
`(save-template-fn ',template-name
(rkr/fn ,fnlist ,@body)))
) ;; eval-when
;; (deftemplate foo (&key (header "bullshit")
;; ;; kinda tasteless to provide default this way...
;; ;; kinda tasteless to provide defaults this way...
;; (body '(:div "the default body"))
;; (time (write-utime-ymdhm (get-universal-time))))
;; (time "To Die"))
;; ;; the above alternative is impossible to implement.
;; `(let ((time ,time))
;; (html
......@@ -151,8 +157,7 @@
;; (:body time
;; (:div ,header)
;; (:div ,body)
;; time))))
;; )
;; time)))))
;; (html (:template :foo))
......
......@@ -4,11 +4,11 @@
(:shadowing-import-from :arnesi
:copy-file :random-string
:quit
:compose)
(:import-from :arnesi
:no-call/cc-form
:no-call/cc)
:compose
:it :awhen :aand :acond :aif :acond2)
;;(:import-from :arnesi :no-call/cc)
(:shadowing-import-from :cl-ppcre :quote-meta-chars)
#+(or)
(:shadowing-import-from :kmrcl
:it :awhen :aand :acond :aif :awhen2 :aif2 :acond2)
(:export
......@@ -71,68 +71,68 @@
#:with-reducer
#:with-collector
#:with-collectors
;; walker
;; ;; walker
#:walk-form
#:make-walk-env
#:*walk-handlers*
#:*warn-undefined*
#:defwalker-handler
#:implicit-progn-mixin
#:implicit-progn-with-declare-mixin
#:binding-form-mixin
#:declaration-form
#:constant-form
#:variable-reference
#:local-variable-reference
#:local-lexical-variable-reference
#:free-variable-reference
#:application-form
#:local-application-form
#:lexical-application-form
#:free-application-form
#:lambda-application-form
#:function-form
#:lambda-function-form
#:function-object-form
#:local-function-object-form
#:free-function-object-form
#:lexical-function-object-form
#:function-argument-form
#:required-function-argument-form
#:specialized-function-argument-form
#:optional-function-argument-form
#:keyword-function-argument-form
#:allow-other-keys-function-argument-form
#:rest-function-argument-form
#:block-form
#:return-from-form
#:catch-form
#:throw-form
#:eval-when-form
#:if-form
#:function-binding-form
#:flet-form
#:labels-form
#:variable-binding-form
#:let-form
#:let*-form
#:locally-form
#:macrolet-form
#:multiple-value-call-form
#:multiple-value-prog1-form
#:progn-form
#:progv-form
#:setq-form
#:symbol-macrolet-form
#:tagbody-form
#:go-tag-form
#:go-form
#:the-form
#:extract-argument-names
#:walk-lambda-list
#:unwalk-form
;; #:make-walk-env
;; #:*walk-handlers*
;; #:*warn-undefined*
;; #:defwalker-handler
;; #:implicit-progn-mixin
;; #:implicit-progn-with-declare-mixin
;; #:binding-form-mixin
;; #:declaration-form
;; #:constant-form
;; #:variable-reference
;; #:local-variable-reference
;; #:local-lexical-variable-reference
;; #:free-variable-reference
;; #:application-form
;; #:local-application-form
;; #:lexical-application-form
;; #:free-application-form
;; #:lambda-application-form
;; #:function-form
;; #:lambda-function-form
;; #:function-object-form
;; #:local-function-object-form
;; #:free-function-object-form
;; #:lexical-function-object-form
;; #:function-argument-form
;; #:required-function-argument-form
;; #:specialized-function-argument-form
;; #:optional-function-argument-form
;; #:keyword-function-argument-form
;; #:allow-other-keys-function-argument-form
;; #:rest-function-argument-form
;; #:block-form
;; #:return-from-form
;; #:catch-form
;; #:throw-form
;; #:eval-when-form
;; #:if-form
;; #:function-binding-form
;; #:flet-form
;; #:labels-form
;; #:variable-binding-form
;; #:let-form
;; #:let*-form
;; #:locally-form
;; #:macrolet-form
;; #:multiple-value-call-form
;; #:multiple-value-prog1-form
;; #:progn-form
;; #:progv-form
;; #:setq-form
;; #:symbol-macrolet-form
;; #:tagbody-form
;; #:go-tag-form
;; #:go-form
;; #:the-form
;; #:extract-argument-names
;; #:walk-lambda-list
;; #:unwalk-form
;; call/cc
:no-call/cc
#:no-call/cc
#:to-cps
#:with-call/cc
#:kall
......
(in-package :it.bese.arnesi)
;;;; I wanted to have a general way to analyze the code-tree.
;;;; This is the half-assed result. Good enough for now.
(defclass no-call/cc-form (form)
((closure :initarg :closure :accessor closure)
(lex-vars :initarg :lex-vars :accessor lex-vars)
#+(or)(dyn-vars :initarg :dyn-vars :accessor dyn-vars)))
(defmacro def-walker (name fnlist &rest cases)
;; assume fnlist are all required args.
(let ((fn-name (symcat name '-method)))
`(progn
(defmethod ,fn-name (form ,@fnlist))
(flet ((rec (form) (generic-walker form ,fn-name)))
(def-walker-methods ,fn-name ,fnlist ,@cases))
(defun ,name (form ,@fnlist)
(generic-walker form (rcurry (function ,fn-name) ,@fnlist))))))
(defmacro def-walker-methods (fn-name fn-list &rest cases)
(with-unique-names (form)
`(progn
(defgeneric ,fn-name (form ,@fn-list))
,@(mapcar (lambda (case)
(let* ((type (car case))
(slots (cadr case))
(body (cddr case)))
`(defmethod ,fn-name ((it ,type) ,@fn-list)
(with-slots ,slots it
,@body))))
cases))))
(defmacro def-generic-walker-methods (&rest cases)
`(macrolet ((rec (form) `(generic-walker ,form fn)))
(macrolet ((rec* (forms) `(dolist (form ,forms)
(rec form))))
(fmakunbound 'generic-walker)
(defgeneric generic-walker (form fn))
,@(mapcar (lambda (case)
(let* ((type (car case))
(slots (cadr case))
(body (cddr case)))
`(defmethod generic-walker ((it ,type) fn)
(with-slots ,slots it
(funcall fn it)
,@body))))
cases)
(defmethod generic-walker (form fn)
(funcall fn form)))))
(def-generic-walker-methods
(application-form (operator arguments)
(rec operator)
(rec* arguments))
(lambda-function-form (arguments body)
(rec* arguments)
(rec* body))
(function-object-form (name)
(rec name))
#+(or)(function-argument-form () (funcall fn it))
;; (required-function-argument-form (name) (funcall fn it))
#+(or)(specialized-function-argument-form (name specializer)
(if (eq specializer t)
name
`(,name ,specializer)))
(optional-function-argument-form (default-value)
(rec default-value))
(keyword-function-argument-form (default-value)
(rec default-value))
#+(or)(allow-other-keys-function-argument-form ()
'&allow-other-keys)
#+(or)(rest-function-argument-form (name)
name)
;;;; BLOCK/RETURN-FROM
(block-form (body)
(rec* body))
(return-from-form (result)
(rec result))
;;;; CATCH/THROW
(catch-form (tag body)
(rec tag)
(rec* body))
(throw-form (tag value)
(rec tag)
(rec value))
;;;; EVAL-WHEN
(eval-when-form ()
(error "Sorry, EVAL-WHEN not yet implemented."))
;;;; IF
(if-form (consequent then else)
(rec consequent)
(rec then)
(rec else))
;;;; FLET/LABELS
(function-binding-form (binds body)
(dolist (bind binds)
(rec (cdr bind)))
(rec* body))
;;;; LET/LET*
(variable-binding-form (binds body)
(dolist (bind binds)
(rec (cdr bind)))
(rec* body))
;;;; LOAD-TIME-VALUE
(load-time-value-form (value read-only-p)
(rec value))
;;;; LOCALLY
(locally-form (body)
(rec* body))
;;;; MULTIPLE-VALUE-CALL
(multiple-value-call-form (func arguments)
(rec func)
(rec* arguments))
;;;; MULTIPLE-VALUE-PROG1
(multiple-value-prog1-form (first-form other-forms)
(rec first-form)
(rec* other-forms))
;;;; PROGN
(progn-form (body)
(rec* body))
;;;; PROGV
(progv-form (body vars-form values-form)
(rec vars-form)
(rec values-form)
(rec* body))
;;;; SETQ
(setq-form (value)
(rec value))
;;;; SYMBOL-MACROLET
(symbol-macrolet-form ()
;; We can't unwalk macrolet because, it modifies the body
;; expression, when its created.
(error "Sorry, SYMBOL-MACROLET not yet implemented."))
(macrolet-form ()
;; We can't unwalk macrolet because, it modifies the body
;; expression, when its created.
(rec* (body it)))
;;;; TAGBODY/GO
(tagbody-form (body)
(rec* body))
;;;; THE
(the-form (type-form value)
(rec type-form)
(rec value))
;;;; UNWIND-PROTECT
(unwind-protect-form (protected-form cleanup-form)
(rec protected-form)
(rec* cleanup-form))
;;;; no-call/cc
(no-call/cc-form (lex-vars dyn-vars closure)
(rec lex-vars)
(rec dyn-vars)
(rec closure))
)
(in-package :it.bese.arnesi)
(use-package :wisp-util)
(defun lookup (environment type name &key (error-p nil) (default-value nil))
(loop
......@@ -34,6 +36,7 @@
(collect)))
(def-walker free-application (collect)
(free-application-form () (funcall collect it)))
......@@ -54,15 +57,16 @@
(defclass no-call/cc-form (form)
((closure :initarg :closure :accessor closure)
(lex-vars :initarg :lex-vars :accessor lex-vars)
#+(or)(dyn-vars :initarg :dyn-vars :accessor dyn-vars)))
(defparameter *nesting-no-call/cc?* nil)
(defmacro no-call/cc (&rest body)
"Used to get rid of any nesting no-call/cc, or those that don't appear within with-call/cc."
`(progn ,@body))
(defwalker-handler no-call/cc (form parent env)
"Makes the closure to be run in normal lisp mode.
`setf/q' doesn't work across the call boundary."
......@@ -79,10 +83,12 @@
(lex-vars (intersection local-vars free-vars :key #'name))
;; ;; I found out later that I need all the special-variables found at runtime.
#+(or)(dyn-vars (set-difference free-vars lex-vars :key #'name))
(free-apps (collect-free-apps closure-body))
(local-apps (collect-local-apps body))
(lex-apps (intersection local-apps free-apps :key #'operator)))
(when lex-apps (error "Damn, this is impossible! Can't refer to local functions estabalished in call/cc"))
#+(or)(free-apps (collect-free-apps closure-body))
#+(or)(local-apps (collect-local-apps body))
#+(or)(lex-apps (intersection local-apps free-apps :key #'operator))
lex-apps ;; use nil for now, so the machinery for analyzing local functions doesn't break.
)
#+(or)(when lex-apps (error "Damn, this is impossible! Can't refer to local functions estabalished in call/cc"))
;; We find all the free variables in the closure body. Some of
;; these are lexical variables established outside the closure
;; body (others are special variables).
......@@ -107,9 +113,7 @@
,(no-call/cc-fn-binds lex-apps body-source env))
)))))))
(defmacro no-call/cc (&rest body)
"Used to get rid of any nesting no-call/cc, or those that don't appear within with-call/cc."
`(progn ,@body))
;; by the time I am done with this, I would've written apt-get...
;; I give up.
......@@ -192,164 +196,3 @@ no-call/cc closure. In correct nesting order. "
(apply closure lex-vals))))))
;;;; I wanted to have a general way to analyze the code-tree.
;;;; This is the half-assed result. Good enough for now.
(defmacro def-walker (name fnlist &rest cases)
;; assume fnlist are all required args.
(let ((fn-name (symcat name '-method)))
`(progn
(defmethod ,fn-name (form ,@fnlist))
(flet ((rec (form) (generic-walker form ,fn-name)))
(def-walker-methods ,fn-name ,fnlist ,@cases))
(defun ,name (form ,@fnlist)
(generic-walker form (rcurry (function ,fn-name) ,@fnlist))))))
(defmacro def-walker-methods (fn-name fn-list &rest cases)