Unverified Commit ff501dc4 authored by Vladimir Sedach's avatar Vladimir Sedach Committed by GitHub
Browse files

Merge pull request #37 from neil-lindquist/improve-ps-loop

Improve loop
parents beec0f72 76caf079
......@@ -64,9 +64,11 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *loop-keywords*
'(:named :for :repeat :with :while :until :initially :finally
:from :to :below :downto :above :by :in :across :on := :then
:when :unless :if :else :end :do :return
:sum :collect :append :count :minimize :maximize :map :of :into))
:from :downfrom :to :below :downto :above :by :in :across :on := :then
:when :unless :if :else :end :do :doing :return
:sum :summing :collect :collecting :append :appending :count :counting
:minimize :minimizing :maximize :maximizing :map :mapping
:of :into))
(defun as-keyword (key)
(cond ((not (symbolp key)) key)
......@@ -126,24 +128,24 @@
(defun maybe-hoist (expr state)
(cond ((complex-js-expr? expr)
(let ((var (ps-gensym)))
(push (list var expr) (prologue state))
(push (list 'setf var expr) (prologue state))
var))
(t expr)))
(defun for-from (var state)
(defun for-from (from-key var state)
(unless (atom var)
(err "an atom after FROM" var))
(let ((start (eat state))
(op '+)
(test-op nil)
(op (loop-case from-key (:downfrom '-) (otherwise '+)))
(test-op (loop-case from-key (:downfrom '>=) (otherwise '<=)))
(by nil)
(end nil))
(loop while (member (as-keyword (peek state)) '(:to :below :downto :above :by)) do
(let ((term (eat state)))
(if (eq (as-keyword term) :by)
(setf by (eat state))
(setf op (loop-case term ((:downto :above) '-) (otherwise '+))
test-op (loop-case term (:to '<=) (:below '<) (:downto '>=) (:above '>))
(setf op (loop-case term ((:downto :above) '-) (otherwise op))
test-op (loop-case term (:to test-op) (:below '<) (:downto '>=) (:above '>))
end (eat state)))))
(let ((test (when test-op
(list test-op var (maybe-hoist end state)))))
......@@ -198,7 +200,7 @@
(let ((place (eat state))
(term (eat state :atom)))
(loop-case term
(:from (for-from place state))
((:from :downfrom) (for-from term place state))
(:= (for-= place state))
((:in :across) (for-in place state))
(:on (for-on place state))
......@@ -207,7 +209,7 @@
(defun a-with-clause (state) ;; so named to avoid with-xxx macro convention
(let ((place (eat state)))
(push (list place (eat state :if :=)) (prologue state))))
(push (list 'setf place (eat state :if :=)) (prologue state))))
(defun accumulate (kind item var state)
(when (null var)
......@@ -216,25 +218,25 @@
(unless (accum-var state)
(setf (accum-var state)
(ps-gensym (string (loop-case kind
(:minimize 'min)
(:maximize 'max)
((:minimize :minimizing) 'min)
((:maximize :maximizing) 'max)
(t kind)))))
(setf (accum-kind state) kind))
(setf var (accum-var state)))
(let ((initial (loop-case kind
((:sum :count) 0)
((:maximize :minimize) nil)
((:collect :append) '[])
((:map) '{}))))
(push (list var initial) (prologue state)))
((:sum :summing :count :counting) 0)
((:maximize :maximizing :minimize :minimizing) nil)
((:collect :collecting :append :appending) '[])
((:map :mapping) '{}))))
(push (list 'setf var initial) (prologue state)))
(loop-case kind
(:sum `(incf ,var ,item))
(:count `(when ,item (incf ,var))) ;; note the JS semantics - neither 0 nor "" will count
(:minimize `(setf ,var (if (null ,var) ,item (min ,var ,item))))
(:maximize `(setf ,var (if (null ,var) ,item (max ,var ,item))))
(:collect `((@ ,var 'push) ,item))
(:append `(setf ,var (append ,var ,item)))
(:map (destructuring-bind (key val) item
((:sum :summing)`(incf ,var ,item))
((:count :counting)`(when ,item (incf ,var))) ;; note the JS semantics - neither 0 nor "" will count
((:minimize :minimizing) `(setf ,var (if (null ,var) ,item (min ,var ,item))))
((:maximize :maximizing) `(setf ,var (if (null ,var) ,item (max ,var ,item))))
((:collect :collecting) `((@ ,var 'push) ,item))
((:append :appending) `(setf ,var (append ,var ,item)))
((:map :mapping) (destructuring-bind (key val) item
`(setf (getprop ,var ,key) ,val)))))
(defun repeat-clause (state)
......@@ -274,15 +276,16 @@
(otherwise test-form))
(progn ,@(reverse seqs))
(progn ,@(reverse alts))))))
((:sum :collect :append :count :minimize :maximize)
((:sum :summing :collect :collecting :append :appending :count :counting
:minimize :minimizing :maximize :maximizing)
(accumulate term (eat state) (eat state :if :into) state))
(:map (let ((key (eat state)))
((:map :mapping) (let ((key (eat state)))
(multiple-value-bind (val valp)
(eat state :if :to)
(unless valp
(error "MAP must be followed by a TO to specify value."))
(accumulate :map (list key val) (eat state :if :into) state))))
(:do (eat state :progn))
((:do :doing) (eat state :progn))
(:return `(return-from ,(name state) ,(eat state)))
(otherwise (err "a PS-LOOP keyword" term))))
......@@ -291,6 +294,7 @@
(loop-case term
(:named (setf (name state) (eat state :symbol)))
(:with (a-with-clause state))
(:initially (push (eat state :progn) (prologue state)))
(:for (for-clause state))
(:repeat (repeat-clause state))
(:while (while-clause state))
......@@ -389,11 +393,15 @@
(defun prologue-wrap (prologue body)
(cond ((null prologue) body)
(t (destructuring-bind (place expr) (car prologue)
((equal 'setf (caar prologue))
(destructuring-bind (place expr) (cdr (car prologue))
(prologue-wrap
(cdr prologue)
(cond ((atom place) (cons `(var ,place ,expr) body))
(t `((bind ,place ,expr ,@body)))))))))
(t `((bind ,place ,expr ,@body)))))))
(t (prologue-wrap
(cdr prologue)
(cons (car prologue) body)))))
(defpsmacro loop (&rest keywords-and-forms)
(let ((state (parse-ps-loop keywords-and-forms)))
......
......@@ -356,7 +356,7 @@
(test-js-eval for-obj-place-in
(loop :for (:a :b) :in (list (create :a 2 :b 3)
(create :a 4 :b 5))
:sum (+ a b))
:summing (+ a b))
14)
(test-js-eval for-arr-place-=
......@@ -371,7 +371,7 @@
(test-js-eval loop-until1
(let ((x 0))
(loop :do (incf x) :until t)
(loop :doing (incf x) :until t)
x)
1)
......@@ -400,6 +400,26 @@
(loop :for i :from 0 :below 10 :by 3 :append (list i (* i 100)))
'(0 0 3 300 6 600 9 900))
(test-js-eval loop-appending
(loop :for i :from 0 :below 10 :by 3 :appending (list i (* i 100)))
'(0 0 3 300 6 600 9 900))
(test-js-eval loop-maximize
(loop :for i :in (list 1 5 3 2) :maximize i)
5)
(test-js-eval loop-maximizing
(loop :for i :in (list 1 5 3 7) :maximizing i)
7)
(test-js-eval loop-minimize
(loop :for i :in (list 1 5 3 2) :minimize i)
1)
(test-js-eval loop-minimizing
(loop :for i :in (list 3 5 3 2) :minimizing i)
2)
(test-js-eval loop-for-on
(loop :for (a b) :on '(10 20 30 40 50 60) :by 2 :collect (list b a))
'((20 10) (40 30) (60 50)))
......@@ -407,7 +427,7 @@
(test-js-eval loop-parallel-clauses-with-return
(loop :for i :from 0 :below 10 :for x = (* i 10)
:when (> i 5) :do (return x)
:collect i)
:collecting i)
60)
(test-js-eval loop-extended-conditional-clauses
......@@ -438,6 +458,16 @@
bar)
'(1 2 2 1 3 4 4 2 5 6 6 3 21))
(test-js-eval for-loop-downfrom-to
(loop for i :downfrom 5 :to 0
collect i)
'(5 4 3 2 1 0))
(test-js-eval for-loop-downfrom-above
(loop for i :downfrom 5 :above 0
collect i)
'(5 4 3 2 1))
(test-js-eval loop-conditional-return-works
(block nil
(dotimes (i 10)
......
Supports Markdown
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