Permalink
Browse files

added support for :keys in table binder.

  • Loading branch information...
1 parent fe8bd80 commit 200246e6f633e68b9c01457bbb9bcb6e65902222 @VincentToups committed Jun 8, 2009
Showing with 56 additions and 7 deletions.
  1. +14 −2 defn.el
  2. +34 −5 parse-table-binder.el
  3. +8 −0 utils.el
View
16 defn.el
@@ -51,7 +51,9 @@
(let-seq (sub-binders
keys
as-sym
- or-form) (parse-and-check-tbl-binder binder)
+ or-form
+ keys-seq) (parse-and-check-tbl-binder binder)
+ (if (not as-sym) (setf as-sym (gensym (format "%s-as-symbol" currently-defining-defn))))
(let
((or-form-name nil)
(previous-lets (append previous-lets (handle-binding as-sym expr))))
@@ -61,6 +63,11 @@
(setf or-form-name (gensym "or-form-name"))
(setf previous-lets
(suffix previous-lets (vector or-form-name `(funcall ,or-form))))))
+
+ (if keys-seq
+ (loop for s across keys-seq do
+ (setf keys (suffix keys (make-keyword (format "%s" s))))
+ (setf sub-binders (suffix sub-binders s))))
(append
previous-lets
(loop for kw in keys
@@ -71,6 +78,7 @@
(handle-binding sym `(tbl-or ,as-sym ,kw (tbl ,or-form-name ,kw)))))))))
; (handle-tbl-binding [:: [a b] :x y :y :as table :or (tbl! :x [1 2])] '(tbl 'x 10 'y 11) '())
+; (handle-tbl-binding [:: [a b :as q] :x :keys [y z]] '(tbl :x 10 :y 11 :z 14) '())
(defun* handle-binding (binder expr &optional
(previous-lets '()))
@@ -158,6 +166,8 @@
`(let ((currently-defining-defn ',name))
(fset ',name (fn ,@rest))))
+(provide 'defn)
+
; (defn f (x x) ([a b] (+ a b) ))
; (defn a-test-f [x y [:: z :z :as a-tble :as eh]] (list (+ x y z) a-tble))
@@ -168,7 +178,9 @@
; (defn f [z [:: a :a :as a-table :or (tbl! :a 100)]] (list z a))
; (f 10 (tbl!))
-
+
+; (defn f [z [:: :keys [a b c]]] (list z (+ a b c)))
+; (f 10 (tbl! :a 1 :b 2 :c 3))
View
@@ -6,6 +6,22 @@
(setq currently-defining-defn 'lambda)
+(defun key->count-key (it)
+ (case it
+ (:as :n-as)
+ (:or :n-or)
+ (:keys :n-keys)))
+
+(defun check-keys-form (form)
+ (and (vectorp form)
+ (foldl
+ (lambda (it ac)
+ (and (not (keywordp it))
+ (symbolp it)
+ ac))
+ t
+ (vector->list form))))
+
(defun parse-tbl-special-forms (it ac)
(let-tbl
((i :i)
@@ -20,9 +36,10 @@
(cond
((oddp i)
(if (or
+ (eq :keys it)
(eq :as it)
(eq :or it))
- (let* ((count-key (case it (:as :n-as) (:or :n-or)))
+ (let* ((count-key (key->count-key it))
(n-special-form (+ 1 (tbl ac count-key))))
(if (> n-special-form 1) (error "More than one %s clause in table binder in %s." it currently-defining-defn))
(tbl! ac
@@ -31,8 +48,15 @@
count-key n-special-form))
(error "Unrecognized special form keyword %s in %s" it currently-defining-defn)))
((evenp i)
- (let ((spec-key (case prev (:as :as-sym) (:or :or-form))))
+ (let ((spec-key (case prev (:as :as-sym) (:or :or-form) (:keys :keys-seq))))
(case prev
+ (:keys
+ (if (check-keys-form it)
+ (tbl! ac
+ :i (+ i 1)
+ :prev it
+ spec-key it)
+ (error ":keys must be followed by a vector of symbols, got %s instead in %s." it currently-defining-defn)))
(:as
(if (symbolp it)
(tbl! ac
@@ -55,6 +79,8 @@
(as-sym :as-sym)
(or-form :or-form)
(binders :binders)
+ (n-keys :n-keys)
+ (keys-seq :keys-seq)
(keys :keys)) ac
(cond
((oddp i)
@@ -80,7 +106,8 @@
((binders :binders)
(keys :keys)
(as-sym :as-sym)
- (or-form :or-form))
+ (or-form :or-form)
+ (keys-seq :keys-seq))
(foldl
(lambda (it ac)
(let-tbl
@@ -109,16 +136,18 @@
:state :init
:n-as 0
:n-or 0
+ :n-keys 0
:as-sym nil
:or-form nil
+ :keys-seq nil
:prev nil
:binders '()
:keys '())
(vector->list binder))
- (list binders keys as-sym or-form)))
+ (list binders keys as-sym or-form keys-seq)))
(comment
- (parse-and-check-tbl-binder [:: a :a b :b c :c :as all :or something]))
+ (parse-and-check-tbl-binder [:: a :a b :b c :c :as all :or something :keys [q r s]]) )
(provide 'parse-table-binder)
View
@@ -88,6 +88,9 @@
(defun insertf (&rest args)
(insert (apply #'format args)))
+(defun make-keyword (name)
+ (intern (format ":%s" name)))
+
(defun bang (sym)
(intern (format "%s!" sym)))
(defun s-cat (sym1 sym2)
@@ -398,6 +401,11 @@
(loop for i from 1 below (length v)
collect (elt v i))))
+(defun* elt-or (seq n &optional (otherwise nil))
+ (if (< n (length seq)) (elt seq n) otherwise))
+;; (elt-or [a b c] 3 'd)
+;; (elt [a b c] 1)
+
;; (split-list-left '(1 2 3 4 5) 4)
;; (split-list-right '(1 2 3 4 5) 3)
;; (split-list-drop '(1 2 3 4 5) 3)

0 comments on commit 200246e

Please sign in to comment.