-(in-package :parenscript)
-
-(defun complex-js-expr? (expr)
- (if (symbolp expr)
- (or (find #\. (symbol-name expr))
- (not (eq (ps-macroexpand expr) expr)))
- (consp expr)))
-
-(defvar *loop-keywords*
- '(:for :do :when :unless :initially :finally :first-time :last-time :while :until
- :from :to :below :downto :above :by :in :across :on :index := :then :sum :collect
- :count :minimize :maximize :into :repeat))
-
-(defun normalize-loop-keywords (args)
- (mapcar
- (lambda (x)
- (or (find-if (lambda (key) (and (symbolp x) (equal (symbol-name x) (symbol-name key))))
- *loop-keywords*)
- x))
- args))
-
-(defun reduce-function-symbol (sym)
- (if (and (consp sym) (eq 'function (first sym)))
- (second sym)
- sym))
-
-(defun parse-ps-loop (terms)
- (let (prologue
- init-step-forms end-test-forms
- initially finally
- first-time last-time
- default-accum-var default-accum-kind
- destructurings body)
- (macrolet ((with-local-var ((name expr) &body body)
- (once-only (expr)
- `(let ((,name (aif (and (complex-js-expr? ,expr) (ps-gensym))
- (progn (push (list 'var it ,expr) prologue)
- it)
- ,expr)))
- ,@body))))
- (labels ((next ()
- (car terms))
- (next? (term)
- (eq (next) term))
- (err (expected got)
- (error "PS-LOOP expected ~a, got ~a." expected got))
- (consume (&optional what)
- (let ((term (pop terms)))
- (when (and what (not (eq what term)))
- (err what term))
- term))
- (consume-atom ()
- (if (atom (next))
- (consume)
- (err "an atom" (next))))
- (consume-progn ()
- (cons 'progn (loop :collect (if (consp (next))
- (consume)
- (err "a compound form" (next)))
- :until (atom (next)))))
- (consume-if (term)
- (when (next? term)
- (consume)
- (consume)))
- (accumulate (kind term var)
- (when (null var)
- (when (and default-accum-kind (not (eq kind default-accum-kind)))
- (error "PS-LOOP encountered illegal ~a: ~a was already declared, and there can only be one kind of default accumulation per loop." kind default-accum-kind))
- (unless default-accum-var
- (setf default-accum-var (ps-gensym (case kind
- (:minimize 'min)
- (:maximize 'max)
- (t kind)))
- default-accum-kind kind))
- (setf var default-accum-var))
- (let ((initial (case kind
- ((:sum :count) 0)
- ((:maximize :minimize) nil)
- (:collect '(array)))))
- (pushnew `(var ,var ,initial) prologue :key #'second))
- (case kind
- (:sum `(incf ,var ,term))
- (:count `(unless (null ,term) (incf ,var)))
- (:minimize `(setf ,var (if (null ,var) ,term (min ,var ,term))))
- (:maximize `(setf ,var (if (null ,var) ,term (max ,var ,term))))
- (:collect `((@ ,var :push) ,term))))
- (body-clause (term)
- (case term
- ((:when :unless) (list (intern (symbol-name term))
- (consume)
- (body-clause (consume-atom))))
- ((:sum :collect :count :minimize :maximize) (accumulate term (consume) (consume-if :into)))
- (:do (consume-progn))
- (otherwise (err "a PS-LOOP keyword" term))))
- (for-from (var)
- (let ((start (consume))
- (op '+)
- (test nil)
- (by nil)
- (end nil))
- (loop while (member (next) '(:to :below :downto :above :by)) do
- (let ((term (consume)))
- (if (eq term :by)
- (setf by (consume))
- (setf op (case term ((:downto :above) '-) (otherwise '+))
- test (case term (:to '>) (:below '>=) (:downto '<) (:above '<=))
- end (consume)))))
- (push `(,var ,start (,op ,var ,(or by 1))) init-step-forms)
- (when test
- (with-local-var (end-var end)
- (push (list test var end-var) end-test-forms)))))
- (for-= (var)
- (let ((start (consume))
- (then (consume-if :then)))
- (push (list var start (or then start)) init-step-forms)))
- (for-in (var)
- (with-local-var (arr (consume))
- (let* ((index (or (consume-if :index) (ps-gensym)))
- (equiv `(:for ,index :from 0 :below (length ,arr)
- :for ,var := (aref ,arr ,index))))
- (setf terms (append equiv terms))
- (clause)
- (clause))))
- (for-on (var)
- (with-local-var (arr (consume))
- (push `(or (null ,var) (= (length ,var) 0)) end-test-forms)
- (let* ((by (aif (consume-if :by)
- `(,(reduce-function-symbol it) ,var)
- `((@ ,var :slice) 1)))
- (equiv `(:for ,var := ,arr :then ,by)))
- (setf terms (append equiv terms))
- (clause))))
- (for-clause ()
- (let* ((place (consume))
- (var (when (atom place) place))
- (varlist (unless var place))
- (term (consume-atom)))
- (when varlist
- (when (eq term :from)
- (err "an atom after FOR" varlist))
- (setf var (ps-gensym))
- (push (list varlist var) destructurings))
- (case term
- (:from (for-from var))
- (:= (for-= var))
- ((:in :across) (for-in var))
- (:on (for-on var))
- (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." var term)))))
- (repeat-clause ()
- (let ((index (ps-gensym)))
- (setf terms (append `(:for ,index :from 0 :below ,(consume)) terms))
- (clause)))
- (clause ()
- (let ((term (consume-atom)))
- (case term
- (:for (for-clause))
- (:repeat (repeat-clause))
- (:while (push `(unless ,(consume) break) body))
- (:until (push `(when ,(consume) break) body))
- (:initially (push (consume-progn) initially))
- (:finally (push (consume-progn) finally))
- (:first-time (push (consume-progn) first-time))
- (:last-time (push (consume-progn) last-time))
- (otherwise (push (body-clause term) body))))))
- (if terms
- (loop :while terms :do (clause))
- (err "loop definition" nil)))
- (flet ((end-test ()
- (aif (nreverse end-test-forms)
- (if (cdr it)
- (list (cons 'or it))
- it)
- (list nil)))
- (add-destructurings-to-body ()
- (setf body (nreverse body))
- (loop :for (list var) :in destructurings :do
- (setf body `((destructuring-bind ,list ,var ,@body))))
- body))
- (values (nreverse prologue)
- (nreverse init-step-forms)
- (end-test)
- (nreverse initially)
- (nreverse finally)
- (nreverse first-time)
- (nreverse last-time)
- default-accum-var
- (add-destructurings-to-body))))))
-
-(defpsmacro loop (&rest args)
- (multiple-value-bind (prologue
- init-step-forms end-test
- initially finally
- first-time last-time
- default-accum-var
- body)
- (parse-ps-loop (normalize-loop-keywords args))
- (let ((first-guard (and first-time (ps-gensym)))
- (last-guard (and last-time (ps-gensym))))
- `(,@(if default-accum-var '(with-lambda ()) '(progn))
- ,@(when first-time `((var ,first-guard t)))
- ,@(when last-time `((var ,last-guard nil)))
- ,@prologue
- ,@initially
- (do* ,init-step-forms
- ,end-test
- ,@(when first-time
- `((when ,first-guard
- ,@first-time
- (setf ,first-guard nil))))
- ,@body
- ,@(when last-time
- `((setf ,last-guard t))))
- ,@(when last-time `((when ,last-guard ,@last-time)))
- ,@finally
- ,@(when default-accum-var `((return ,default-accum-var)))))))
+(in-package :parenscript)
+
+(defun complex-js-expr? (expr)
+ (if (symbolp expr)
+ (or (find #\. (symbol-name expr))
+ (not (eq (ps-macroexpand expr) expr)))
+ (consp expr)))
+
+(defvar *loop-keywords*
+ '(:for :do :when :unless :initially :finally :first-time :last-time :while :until
+ :from :to :below :downto :above :by :in :across :on :index := :then :sum :collect
+ :count :minimize :maximize :into :repeat))
+
+(defun normalize-loop-keywords (args)
+ (mapcar
+ (lambda (x)
+ (or (find-if (lambda (key) (and (symbolp x) (equal (symbol-name x) (symbol-name key))))
+ *loop-keywords*)
+ x))
+ args))
+
+(defun reduce-function-symbol (sym)
+ (if (and (consp sym) (eq 'function (first sym)))
+ (second sym)
+ sym))
+
+(defun err (expected got)
+ (error "PS-LOOP expected ~a, got ~a." expected got))
+
+(defclass loop-state ()
+ ((tokens :initarg :tokens :accessor tokens)
+ (iterations :initform nil :accessor iterations)
+ (prologue :initform nil :accessor prologue)
+ (destructurings :initform nil :accessor destructurings)
+ (initially :initform nil :accessor initially)
+ (finally :initform nil :accessor finally)
+ (during-first :initform nil :accessor during-first)
+ (during-last :initform nil :accessor during-last)
+ (default-accum-var :initform nil :accessor default-accum-var)
+ (default-accum-kind :initform nil :accessor default-accum-kind)
+ (body :initform nil :accessor body)))
+
+(defun nreverse-loop-state (state)
+ (macrolet ((rev% (&rest accs)
+ (cons 'progn (loop :for a :in accs :collect `(setf (,a state) (nreverse (,a state)))))))
+ (rev% iterations prologue initially finally during-first during-last)
+ (let ((body (nreverse (body state))))
+ (loop :for (list var) :in (destructurings state) :do
+ (setf body `((destructuring-bind ,list ,var ,@body))))
+ (setf (body state) body)))
+ state)
+
+(defun push-tokens (state toks)
+ (setf (tokens state) (append toks (tokens state))))
+
+(defun peek (state)
+ (car (tokens state)))
+
+(defun eat (state &optional what tag)
+ (case what
+ (:if (when (eq (peek state) tag)
+ (eat state)
+ (eat state)))
+ (:progn (cons 'progn (loop :collect (if (consp (peek state))
+ (eat state)
+ (err "a compound form" (peek state)))
+ :until (atom (peek state)))))
+ (otherwise (let ((tok (pop (tokens state))))
+ (when (and (eq what :atom) (not (atom tok)))
+ (err "an atom" tok))
+ tok))))
+
+(defmacro with-local-var ((name expr state) &body body)
+ (once-only (expr)
+ `(let ((,name (aif (and (complex-js-expr? ,expr) (ps-gensym))
+ (progn (push (list 'var it ,expr) (prologue ,state))
+ it)
+ ,expr)))
+ ,@body)))
+
+(defun for-from (var state)
+ (let ((start (eat state))
+ (op '+)
+ (test-op nil)
+ (by nil)
+ (end nil))
+ (loop while (member (peek state) '(:to :below :downto :above :by)) do
+ (let ((term (eat state)))
+ (if (eq term :by)
+ (setf by (eat state))
+ (setf op (case term ((:downto :above) '-) (otherwise '+))
+ test-op (case term (:to '>) (:below '>=) (:downto '<) (:above '<=))
+ end (eat state)))))
+ (let ((test (when test-op
+ (with-local-var (v end state)
+ (list test-op var v)))))
+ (push `(,var ,start (,op ,var ,(or by 1)) ,test) (iterations state)))))
+
+(defun for-= (var state)
+ (let ((start (eat state))
+ (then (eat state :if :then)))
+ (push (list var start (or then start) nil) (iterations state))))
+
+(defun for-in (var state)
+ (with-local-var (arr (eat state) state)
+ (let ((index (or (eat state :if :index) (ps-gensym))))
+ (push-tokens state `(,index :from 0 :below (length ,arr)
+ ,var := (aref ,arr ,index)))
+ (for-clause state)
+ (for-clause state))))
+
+(defun for-on (var state)
+ (with-local-var (arr (eat state) state)
+ (let ((by (aif (eat state :if :by)
+ `(,(reduce-function-symbol it) ,var)
+ `((@ ,var :slice) 1))))
+ (push-tokens state `(,var := ,arr :then ,by))
+ (for-clause state)
+ ;; set the end-test
+ (setf (fourth (car (iterations state))) `(or (null ,var) (= (length ,var) 0))))))
+
+(defun for-clause (state)
+ (let* ((place (eat state))
+ (var (when (atom place) place))
+ (varlist (unless var place))
+ (term (eat state :atom)))
+ (when varlist
+ (when (eq term :from)
+ (err "an atom after FROM" varlist))
+ (setf var (ps-gensym))
+ (push (list varlist var) (destructurings state)))
+ (case term
+ (:from (for-from var state))
+ (:= (for-= var state))
+ ((:in :across) (for-in var state))
+ (:on (for-on var state))
+ (otherwise (error "FOR ~s ~s is not valid in PS-LOOP." var term)))))
+
+(defun accumulate (kind term var state)
+ (when (null var)
+ (when (and (default-accum-kind state) (not (eq kind (default-accum-kind state))))
+ (error "PS-LOOP encountered illegal ~a: ~a was already declared, and there can only be one kind of default accumulation per loop." kind (default-accum-kind state)))
+ (unless (default-accum-var state)
+ (setf (default-accum-var state)
+ (ps-gensym (case kind
+ (:minimize 'min)
+ (:maximize 'max)
+ (t kind))))
+ (setf (default-accum-kind state) kind))
+ (setf var (default-accum-var state)))
+ (let ((initial (case kind
+ ((:sum :count) 0)
+ ((:maximize :minimize) nil)
+ (:collect '(array)))))
+ (pushnew `(var ,var ,initial) (prologue state) :key #'second))
+ (case kind
+ (:sum `(incf ,var ,term))
+ (:count `(unless (null ,term) (incf ,var)))
+ (:minimize `(setf ,var (if (null ,var) ,term (min ,var ,term))))
+ (:maximize `(setf ,var (if (null ,var) ,term (max ,var ,term))))
+ (:collect `((@ ,var :push) ,term))))
+
+(defun repeat-clause (state)
+ (let ((index (ps-gensym)))
+ (setf (tokens state) (append `(,index :from 0 :below ,(eat state)) (tokens state)))
+ (for-clause state)))
+
+(defun body-clause (term state)
+ (case term
+ ((:when :unless) (list (intern (symbol-name term))
+ (eat state)
+ (body-clause (eat state :atom) state)))
+ ((:sum :collect :count :minimize :maximize) (accumulate term (eat state) (eat state :if :into) state))
+ (:do (eat state :progn))
+ (otherwise (err "a PS-LOOP keyword" term))))
+
+(defun clause (state)
+ (let ((term (eat state :atom)))
+ (case term
+ (:for (for-clause state))
+ (:repeat (repeat-clause state))
+ (:while (push `(unless ,(eat state) break) (body state)))
+ (:until (push `(when ,(eat state) break) (body state)))
+ (:initially (push (eat state :progn) (initially state)))
+ (:finally (push (eat state :progn) (finally state)))
+ (:first-time (push (eat state :progn) (during-first state)))
+ (:last-time (push (eat state :progn) (during-last state)))
+ (otherwise (push (body-clause term state) (body state))))))
+
+(defun parse-ps-loop (terms)
+ (if (null terms)
+ (err "loop definition" nil)
+ (let ((state (make-instance 'loop-state :tokens terms)))
+ (loop :while (tokens state) :do (clause state))
+ (nreverse-loop-state state))))
+
+(defun init-forms (loop)
+ (mapcar (lambda (x) (subseq x 0 2)) (iterations loop)))
+
+(defun step-forms (loop)
+ (mapcar (lambda (x) `(setf ,(first x) ,(third x))) (iterations loop)))
+
+(defun end-test (loop)
+ (aif (loop :for (nil nil nil test) :in (iterations loop) :when test :collect test)
+ (if (cdr it)
+ (list 'not (cons 'or it))
+ (cons 'not it))
+ '(not nil)))
+
+(defpsmacro loop (&rest args)
+ (let* ((loop (parse-ps-loop (normalize-loop-keywords args)))
+ (first-guard (and (during-first loop) (ps-gensym)))
+ (last-guard (and (during-last loop) (ps-gensym))))
+ `(,@(if (default-accum-var loop) '(with-lambda ()) '(progn))
+ ,@(when (during-first loop) `((var ,first-guard t)))
+ ,@(when (during-last loop) `((var ,last-guard nil)))
+ ,@(prologue loop)
+ ,@(initially loop)
+ (for ,(init-forms loop)
+ (,(end-test loop))
+ ,(step-forms loop)
+ ,@(when (during-first loop)
+ `((when ,first-guard
+ ,@(during-first loop)
+ (setf ,first-guard nil))))
+ ,@(body loop)
+ ,@(when (during-last loop)
+ `((setf ,last-guard t))))
+ ,@(when (during-last loop)
+ `((when ,last-guard ,@(during-last loop))))
+ ,@(finally loop)
+ ,@(when (default-accum-var loop) `((return ,(default-accum-var loop)))))))
HCoop / clinton / parenscript.git / commitdiff