Commit 5992fb5a authored by hayeah via gmail com's avatar hayeah via gmail com

Preliminary work on lisplet

darcs-hash:dbbc6fddc3c90e93e6ee13b66fd375c9833e4eb9
parent 39047c3e
(defpackage :wisp-util
(:use :cl :cl-ppcre :cl-interpol :arnesi :kmrcl) ; :it.bese.fiveam)
(:use :cl :unify :cl-ppcre :cl-interpol :arnesi :kmrcl) ; :it.bese.fiveam)
(:shadowing-import-from :arnesi
:copy-file :random-string
:quit
......@@ -8,10 +8,17 @@
:it :awhen :aand :acond :aif :acond2)
;;(:import-from :arnesi :no-call/cc)
(:shadowing-import-from :cl-ppcre :quote-meta-chars)
(:shadowing-import-from :unify
:match-case
:match)
#+(or)
(:shadowing-import-from :kmrcl
:it :awhen :aand :acond :aif :awhen2 :aif2 :acond2)
(:export
:maptree
:def-with-mode
:with
:with-gensym
:intersection-in-order
:split-by-separators
:^string
......@@ -146,7 +153,11 @@
#:defmethod/cc
#:fmakun-cc
#:*debug-evaluate/cc*
#:*trace-cc*
#:*trace-cc*
;; unification
:unify
:match
:match-case
))
......
......@@ -149,6 +149,18 @@
when rest do (raw-string processor ", "))
(raw-string processor ")"))
;; (defmacro deflang ((lang action method) args body))
;; (deflang (js processor method-call) (method-name object arguments)
;; (rec object :exp)
;; (raw ".")
;; (rec method-name :exp)
;; (raw "(")
;; (loop for (arg . rest) on arguments do
;; (rec arg :exp)
;; when rest do (raw ", "))
;; (raw ")"))
(defun process-function-call (language processor environment name arguments)
(let ((function-expression-statement-p
(and (consp name) (eql (car name) 'function) (eql (statement-or-expression environment) :statement))))
......
This diff is collapsed.
;; I want a generic way to define dsl's
;; Arbitrary number of environments.
;; Before and after processing. So I can, for example, see the free
;; variables in subforms, then decide what to do for the top form.
;; Works from AST. Assume it's in s-exp. Already translated from
;; lexer/parser.
;; object oriented so deriving sub-languages from sub-language is
;; easy.
;; need global environment for def forms.
(defpackage :wisp-lisplet
(:use :wisp-util :cl :prolog))
(in-package :wisp-lisplet)
(defmacro deflang (lang-name parent-langs &rest definition &aux rules)
(with
:dbind
(env atoms rules) (cdr (split-by-separators definition '(:env :atoms :rules)))
(atom-defs atom-match-fns) (make-atom-definitions (cdr atoms))
(rule-defs rule-match-fns) (make-rule-definitions (cdr rules))
:do `(progn ,atom-defs
(register-atom-fns ',lang-name ,(cons 'list atom-match-fns))
,rule-defs
(register-rule-fns ',lang-name ,(cons 'list rule-match-fns)))))
;; (defun make-lang-definition (defs rule-making-fn)
;; (let ((types (delete-duplicates (mapcar #'car defs)))
;; parse-fns)
;; (list
;; `(progn ,@(mapcar (fn (type)
;; `(defclass ,type ()))
;; types)
;; ,@(mapcar (fn (def)
;; (let ((type (first def))
;; (matcher (second def))
;; (class-name (third def))
;; (class-slots (fourth def)))
;; (push (funcall rule-making-fn matcher) parse-fns)
;; `(defclass ,class-name (,type)
;; ,(make-class-slots class-slots))))
;; defs))
;; (nreverse parse-fns))))
;; (defun make-atom-definitions (atom-defs)
;; (make-lang-definition atom-defs #'identity))
(defun make-atom-definitions (atom-defs)
(let ((atom-types (delete-duplicates (mapcar #'car atom-defs)))
match-fns)
(list
`(progn ,@(mapcar (fn (atom-type)
`(defclass ,atom-type ()))
atom-types)
,@(mapcar (fn (def)
(let ((atom-type (first def))
(test-fn (second def))
(atom-class-name (third def))
(atom-class-slots (fourth def)))
(push test-fn match-fns)
`(defclass ,atom-class-name (,atom-type)
,(make-class-slots atom-class-slots))))
atom-defs))
(nreverse match-fns))))
(defun make-class-slots (slots)
(loop for slot in slots
collect (list slot :initarg (^keyword slot) :accessor slot)))
(defun make-rule-definitions (rule-defs)
(let ((types (delete-duplicates (mapcar #'car rule-defs)))
match-fns)
(list
`(progn ,@(mapcar (fn (type)
`(defclass ,type ()))
types)
,@(mapcar (fn (def)
(let ((type (first def))
(template (second def))
(class-name (third def))
(class-slots (fourth def)))
(push (make-template-matcher template class-name class-slots) match-fns)
`(defclass ,class-name (,type)
,(make-class-slots class-slots))))
rule-defs))
(nreverse match-fns))))
(defun make-template-matcher (template class-name class-slots)
(with
:let slots class-slots
:collector matches
:flet
(collect-matches (type &rest data)
(when (null slots)
(error "Too many template components for syntax class ~S with slots ~S."
class-name class-slots))
(with :let
match-var (symcat '? (pop slots))
:do
(matches (list* type match-var data))
match-var))
:flet
(rule-match (sub) (collect-matches :rule sub))
(fn-match (sub) (collect-matches :fn sub))
(*-match (sub) (collect-matches :* (cadr sub)))
:flet
(cons-match (sub)
(case (car sub)
(function (fn-match sub))
(* (*-match sub))
(t sub)))
:let
match-template
(maptree (fn (sub) (cond
((null sub) nil)
((keywordp sub) ;;dummy syntax
sub)
((symbolp sub) (rule-match sub))
(t (cons-match sub))))
template)
:do
(if slots
(error "Too few template components for syntax class ~S with slots ~S."
class-name class-slots)
(make-template-matcher-fn match-template class-name class-slots (matches)))))
(defun make-template-matcher-fn (template class-name class-slots matches)
(with :let
match-types (mapcar #'first matches)
match-vars (mapcar #'second matches)
match-data* (mapcar (curry #'nthcdr 2) matches)
block-name (gensym)
:flet
(bind-fn (var val) `(,var ,val))
:do
`(fn (exp)
(block ,block-name
(match (,template exp)
(let ,(mapcar (fn (var type data)
(ecase type
(:fn `(,var (if (funcall ,(car data) ,var)
,var
(return-from ,block-name nil))))
(:* `(,var (match-expression* ,var ',(car data))))
(:rule `(,var (match-expression ,var ',(car data))))
))
match-vars match-types match-data*)
(make-instance ',class-name ,@(mappend (fn (slot var) (list (^keyword slot) var))
class-slots
match-vars))))))))
#|
(make-rule-definitions '((exp (:if exp exp exp) if-exp (test then else))
(exp
(tag (* attribute) (* exp))
html-exp (tag attrbs body))
(attribute
(#'keywordp lisp-exp)
html-attribute (attrb body))))
(deflang common-lisp ()
:atoms
(atom #'atomp cl-atom)
:rules
(function
(:lambda (* binding) (* exp))
lambda-exp (bindings body))
(function
#'symbolp
symbol-function (name))
(exp
(function (* exp))
app-exp)
(exp
(:let ((* binding)) (* declaration) (* exp)))
(exp
atom
atom-exp)
)
(deflang html (common-lisp)
:atoms
(tag
(fn (tag) (find tag '(:div :p)))
block-tag (tag))
(tag
(fn (tag) (find tag '(:span :i :b)))
inline-tag (tag))
(tag
#'keywordp
other-tag (tag))
:rules
(attribute
(#'keywordp lisp-exp)
html-attribute (attrb value))
;; preusmably html inherits from common-lisp, and provides an
;; extension s.t. the car of the form can be a keyword.
;;
;; (dotimes (i 100) (:b i)) would be legal for the html extension.
(exp
(tag (* attribute) (* exp))
html-exp (tag body)))
(defhandle print (foo2 extended-lambda-list)
(print (list whole required optional key aux)))
(defhandle (analyze foo2 extended-lambda-list) (whole required optional key aux)
(combine it (mapcar #'analyze key)))
|#
\ No newline at end of file
......@@ -8,6 +8,14 @@
(n n (1- n)))
((zerop n) body)))
(defun maptree (fn x)
(if (atom x)
(funcall fn x)
(let ((a (funcall fn (car x)))
(d (maptree fn (cdr x))))
(if (and (eql a (car x)) (eql d (cdr x)))
x
(cons a d)))))
......@@ -280,6 +288,13 @@ Return:
(let ((it ,val)) ,@(cdr cl1))
(acond2 ,@(cdr clauses)))))))
(defmacro aprogn (&rest forms)
(cond ((null forms) nil)
((null (cdr forms)) (car forms))
(t
`(let ((it ,(car forms)))
(aprogn ,@(cdr forms))))))
......@@ -824,3 +839,79 @@ Return:
,@body)))))))
(defmacro with (&whole exp &rest clauses)
(let* ((type (car clauses)))
(if (eql type :do)
`(progn ,@ (cdr clauses))
(multiple-value-bind (bind-forms rest)
;; a slight problem. What if I want to bind a variable to keyword?
;; tough luck?
(split-if #'keywordp (cdr clauses))
(aif (gethash type *with-modes*) (funcall it bind-forms `(with ,@rest))
(error "No with-mode is associated to ~S. In ~S" type exp))))))
(defparameter *with-modes* (make-hash-table))
(defmacro def-with-mode (keyword arg-list &rest body)
`(setf (gethash ,keyword *with-modes*)
(fn ,arg-list ,@body)))
(def-with-mode :mvbind (binds rest)
(let ((binds (group binds 2)))
(labels ((rec (binds)
(if (null binds)
rest
`(multiple-value-bind
,(caar binds) ,(cadar binds)
,(rec (cdr binds))))))
(rec binds))))
(def-with-mode :dbind (binds rest)
(let ((binds (group binds 2)))
(labels ((rec (binds)
(if (null binds)
rest
`(destructuring-bind
,(caar binds) ,(cadar binds)
,(rec (cdr binds))))))
(rec binds))))
(def-with-mode :let (binds rest)
(let ((binds (group binds 2)))
`(let ,binds ,rest)))
(def-with-mode :let* (binds rest)
(let ((binds (group binds 2)))
`(let* ,binds ,rest)))
(def-with-mode :flet (binds rest)
`(flet ,binds ,rest))
(def-with-mode :labels (binds rest)
`(labels ,binds ,rest))
(def-with-mode :flet* (binds rest)
`(labels ,binds ,rest))
(def-with-mode :collector (binds rest)
`(with-collectors ,(mapcar (fn (bind)
(aprogn (mklst bind)
(if (> (length it) 2)
(error "Illegal collector ~S." bind)
it)))
binds)
,rest))
(def-with-mode :pusher (binds rest)
`(with-collectors ,(mapcar (fn (bind)
(aprogn (mklst bind)
(cond ((> (length it) 2)
(error "Illegal pusher ~S" bind))
((= (length it) 1) (append it '(nil t)))
(t (append it '(t))))))
binds)
,rest))
......@@ -9,5 +9,7 @@
(put 'defwethod 'common-lisp-indent-function (get 'defmethod 'common-lisp-indent-function))
(put 'defurlmap 'common-lisp-indent-function (get 'case 'common-lisp-indent-function))
(put 'fn 'common-lisp-indent-function (get 'lambda 'common-lisp-indent-function))
(put 'dbind 'common-lisp-indent-function (get 'destructuring-bind 'common-lisp-indent-function))
(put 'mvbind 'common-lisp-indent-function (get 'destructuring-bind 'common-lisp-indent-function))
(put 'def-generic-walker-methods 'common-lisp-indent-function (get 'progn 'common-lisp-indent-function))
\ No newline at end of file
......@@ -54,7 +54,7 @@
:cl-interpol :cl-ppcre
:arnesi :fiveam
:kmrcl
;;:unification
:unification
))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment