;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; literals
(defmacro defpsliteral (name string)
- `(progn (pushnew ',name *ps-literals*)
- (define-ps-special-form ,name (expecting)
- (declare (ignore expecting))
- (list 'js-literal ,string))))
+ `(progn
+ (add-ps-literal ',name)
+ (define-ps-special-form ,name (expecting)
+ (declare (ignore expecting))
+ (list 'js-literal ,string))))
(defpsliteral this "this")
(defpsliteral t "true")
(macrolet ((def-for-literal (name printer)
`(progn
- (pushnew ',name *ps-literals*)
+ (add-ps-literal ',name)
(define-ps-special-form ,name (expecting &optional label)
(declare (ignore expecting))
(list ',printer label)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; unary operators
-(mapcar (lambda (op) (eval `(define-ps-special-form ,op (expecting value)
- (declare (ignore expecting))
- (list 'js-named-operator ',op (compile-parenscript-form value)))))
- '(throw delete void typeof new))
+(macrolet ((def-unary-ops (&rest ops)
+ `(progn ,@(mapcar (lambda (op)
+ (let ((op (if (listp op) (car op) op))
+ (spacep (if (listp op) (second op) nil)))
+ `(define-ps-special-form ,op (expecting x)
+ (declare (ignore expecting))
+ (list 'unary-operator ',op
+ (compile-parenscript-form x :expecting :expression)
+ :prefix t :space ,spacep))))
+ ops))))
+ (def-unary-ops ~ ! (new t) (delete t) (void t) (typeof t)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; statements
(define-ps-special-form return (expecting &optional value)
(declare (ignore expecting))
(list 'js-return (compile-parenscript-form value :expecting :expression)))
+(define-ps-special-form throw (expecting value)
+ (declare (ignore expecting))
+ (list 'js-throw (compile-parenscript-form value :expecting :expression)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; arrays
(define-ps-special-form array (expecting &rest values)
(compile-parenscript-form form :expecting :expression))
coords)))
+(add-ps-literal '{})
(define-ps-special-form {} (expecting &rest arrows)
(declare (ignore expecting))
(cons 'object-literal (loop for (key value) on arrows by #'cddr
(define-ps-special-form incf (expecting x &optional (delta 1))
(declare (ignore expecting))
(if (equal delta 1)
- (list 'unary-operator "++" (compile-parenscript-form x :expecting :expression) :prefix t)
+ (list 'unary-operator '++ (compile-parenscript-form x :expecting :expression) :prefix t)
(list 'operator '+= (list (compile-parenscript-form x :expecting :expression)
(compile-parenscript-form delta :expecting :expression)))))
(define-ps-special-form decf (expecting x &optional (delta 1))
(declare (ignore expecting))
(if (equal delta 1)
- (list 'unary-operator "--" (compile-parenscript-form x :expecting :expression) :prefix t)
+ (list 'unary-operator '-- (compile-parenscript-form x :expecting :expression) :prefix t)
(list 'operator '-= (list (compile-parenscript-form x :expecting :expression)
(compile-parenscript-form delta :expecting :expression)))))
(define-ps-special-form - (expecting first &rest rest)
(declare (ignore expecting))
(if (null rest)
- (list 'unary-operator "-" (compile-parenscript-form first :expecting :expression) :prefix t)
+ (list 'unary-operator '- (compile-parenscript-form first :expecting :expression) :prefix t)
(list 'operator '- (mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
(cons first rest)))))
(let ((form (compile-parenscript-form x :expecting :expression))
(not-op nil))
(if (and (eql (first form) 'operator)
- (= (length (third form)) 2)
+ (= (length (third form)) 2)
(setf not-op (case (second form)
(== '!=)
(< '>=)
(!== '===)
(t nil))))
(list 'operator not-op (third form))
- (list 'unary-operator "!" form :prefix t))))
-
-(define-ps-special-form ~ (expecting x)
- (declare (ignore expecting))
- (list 'unary-operator "~" (compile-parenscript-form x :expecting :expression) :prefix t))
-
-(defpsmacro 1- (form)
- `(- ,form 1))
-
-(defpsmacro 1+ (form)
- `(+ ,form 1))
+ (list 'unary-operator '! form :prefix t))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; control structures
(define-ps-special-form switch (expecting test-expr &rest clauses)
(declare (ignore expecting))
(let ((clauses (mapcar (lambda (clause)
- (let ((val (car clause))
- (body (cdr clause)))
- (cons (if (eql val 'default)
- 'default
- (compile-parenscript-form val :expecting :expression))
+ (let ((val (car clause))
+ (body (cdr clause)))
+ (cons (if (and (symbolp val)
+ (eq (ensure-ps-symbol val) 'default))
+ 'default
+ (compile-parenscript-form val :expecting :expression))
(mapcar (lambda (statement) (compile-parenscript-form statement :expecting :statement))
body))))
- clauses))
- (expr (compile-parenscript-form test-expr :expecting :expression)))
+ clauses))
+ (expr (compile-parenscript-form test-expr :expecting :expression)))
(list 'js-switch expr clauses)))
(defpsmacro case (value &rest clauses)
(labels ((make-clause (val body more)
- (cond ((listp val)
+ (cond ((and (listp val) (not (eq (car val) 'quote)))
(append (mapcar #'list (butlast val))
(make-clause (first (last val)) body more)))
((member val '(t otherwise))
(when (listp spec) (second spec))))
(defpsmacro defaultf (place value)
- `(setf ,place (or (and (=== undefined ,place) ,value)
- ,place)))
+ `(when (=== ,place undefined)
+ (setf ,place ,value)))
(defun parse-extended-function (lambda-list body &optional name)
"Returns two values: the effective arguments and body for a function with
(declare (ignore x y))
(when specified? (cons var val))))
keys))))
- (body-paren-forms (parse-function-body body)) ;remove documentation
- ;;
+ (body-paren-forms (parse-function-body body)) ; remove documentation
(initform-forms
(mapcar #'(lambda (default-pair)
`(defaultf ,(car default-pair) ,(cdr default-pair)))
[&aux {var | (var [init-form])}*])"
(if (symbolp name)
`(defun-function ,name ,lambda-list ,@body)
- (progn (assert (and (= (length name) 2) (eql 'setf (car name))) ()
+ (progn (assert (and (= (length name) 2) (eq 'setf (ensure-ps-symbol (car name)))) ()
"(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
`(defun-setf ,name ,lambda-list ,@body))))
,@effective-body)))
(defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
- (setf (get-macro-spec access-fn *script-setf-expanders*)
+ (setf (get-macro-spec access-fn *ps-setf-expanders*)
(compile nil
(let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords)))
`(lambda (access-fn-args store-form)
(defpsmacro defsetf-short (access-fn update-fn &optional docstring)
(declare (ignore docstring))
- (setf (get-macro-spec access-fn *script-setf-expanders*)
+ (setf (get-macro-spec access-fn *ps-setf-expanders*)
(lambda (access-fn-args store-form)
`(,update-fn ,@access-fn-args ,store-form)))
nil)
;;; macros
(defmacro with-temp-macro-environment ((var) &body body)
`(let* ((,var (make-macro-env-dictionary))
- (*script-macro-env* (cons ,var *script-macro-env*)))
+ (*ps-macro-env* (cons ,var *ps-macro-env*)))
,@body))
(define-ps-special-form macrolet (expecting macros &body body)
(dolist (macro macros)
(destructuring-bind (name arglist &body body)
macro
- (setf (get-macro-spec name macro-env-dict)
- (cons nil (make-ps-macro-function arglist body)))))
+ (setf (get-macro-spec name macro-env-dict)
+ (cons nil (make-ps-macro-function arglist body)))))
(compile-parenscript-form `(progn ,@body))))
(define-ps-special-form symbol-macrolet (expecting symbol-macros &body body)
(dolist (macro symbol-macros)
(destructuring-bind (name expansion)
macro
- (setf (get-macro-spec name macro-env-dict)
- (cons t (make-ps-macro-function () (list `',expansion))))))
+ (setf (get-macro-spec name macro-env-dict)
+ (cons t (make-ps-macro-function () (list `',expansion))))))
(compile-parenscript-form `(progn ,@body))))
(define-ps-special-form defmacro (expecting name args &body body)
(declare (ignore expecting))
- (define-script-macro% name args body :symbol-macro-p nil)
+ (define-ps-macro% name args body :symbol-macro-p nil)
nil)
(define-ps-special-form define-symbol-macro (expecting name expansion)
(declare (ignore expecting))
- (define-script-macro% name () (list `',expansion) :symbol-macro-p t)
+ (define-ps-macro% name () (list `',expansion) :symbol-macro-p t)
nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare (ignore expecting))
(list 'js-object (loop for (name val) on args by #'cddr collecting
(let ((name-expr (compile-parenscript-form name :expecting :expression)))
+ (when (keywordp name-expr)
+ (setf name-expr (list 'js-variable name-expr)))
(assert (or (stringp name-expr)
(numberp name-expr)
(and (listp name-expr)
(or (eql 'js-variable (car name-expr))
- (eql 'script-quote (car name-expr)))))
+ (eql 'ps-quote (car name-expr)))))
()
"Slot ~s is not one of js-variable, keyword, string or number." name-expr)
(list name-expr (compile-parenscript-form val :expecting :expression))))))
(defpsmacro with-slots (slots object &rest body)
(flet ((slot-var (slot) (if (listp slot) (first slot) slot))
- (slot-symbol (slot) (if (listp slot) (second slot) slot)))
+ (slot-symbol (slot) (if (listp slot) (second slot) slot)))
`(symbol-macrolet ,(mapcar #'(lambda (slot)
- `(,(slot-var slot) (slot-value ,object ',(slot-symbol slot))))
- slots)
+ `(,(slot-var slot) (slot-value ,object ',(slot-symbol slot))))
+ slots)
,@body)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun smart-setf (lhs rhs)
(if (and (listp rhs)
(eql 'operator (car rhs))
- (member lhs (third rhs) :test #'equalp))
+ (member lhs (third rhs) :test #'equalp))
(let ((args-without-first (remove lhs (third rhs) :count 1 :end 1 :test #'equalp)))
- (cond ((and (assignment-op (second rhs))
- (member (second rhs) '(+ *))
+ (cond ((and (assignment-op (second rhs))
+ (member (second rhs) '(+ *))
(equalp lhs (first (third rhs))))
- (list 'operator (assignment-op (second rhs))
+ (list 'operator (assignment-op (second rhs))
(list lhs (list 'operator (second rhs) args-without-first))))
- (t (list 'js-assign lhs rhs))))
+ (t (list 'js-assign lhs rhs))))
(list 'js-assign lhs rhs)))
(define-ps-special-form setf1% (expecting lhs rhs)
(defpsmacro setf (&rest args)
(flet ((process-setf-clause (place value-form)
- (if (and (listp place) (get-macro-spec (car place) *script-setf-expanders*))
- (funcall (get-macro-spec (car place) *script-setf-expanders*) (cdr place) value-form)
+ (if (and (listp place) (get-macro-spec (car place) *ps-setf-expanders*))
+ (funcall (get-macro-spec (car place) *ps-setf-expanders*) (cdr place) value-form)
(let ((exp-place (ps-macroexpand place)))
- (if (and (listp exp-place) (get-macro-spec (car exp-place) *script-setf-expanders*))
- (funcall (get-macro-spec (car exp-place) *script-setf-expanders*) (cdr exp-place) value-form)
+ (if (and (listp exp-place) (get-macro-spec (car exp-place) *ps-setf-expanders*))
+ (funcall (get-macro-spec (car exp-place) *ps-setf-expanders*) (cdr exp-place) value-form)
`(setf1% ,exp-place ,value-form))))))
(assert (evenp (length args)) ()
"~s does not have an even number of arguments." (cons 'setf args))
`(progn ,@(loop for (place value) on args by #'cddr collect (process-setf-clause place value)))))
+(defpsmacro psetf (&rest args)
+ (let ((vars (loop for x in args by #'cddr collect x))
+ (vals (loop for x in (cdr args) by #'cddr collect x)))
+ (let ((gensyms (mapcar (lambda (x) (declare (ignore x)) (ps-gensym)) vars)))
+ `(simple-let* ,(mapcar #'list gensyms vals)
+ (setf ,@(mapcan #'list vars gensyms))))))
+
+(defun check-setq-args (args)
+ (let ((vars (loop for x in args by #'cddr collect x)))
+ (let ((non-var (find-if (complement #'symbolp) vars)))
+ (when non-var
+ (error 'type-error :datum non-var :expected-type 'symbol)))))
+
+(defpsmacro setq (&rest args)
+ (check-setq-args args)
+ `(setf ,@args))
+
+(defpsmacro psetq (&rest args)
+ (check-setq-args args)
+ `(psetf ,@args))
+
(define-ps-special-form var (expecting name &rest value)
(declare (ignore expecting))
(append (list 'js-var name)
(simple-let* ,(cdr bindings) ,@body)))
`(progn ,@body)))
+(defpsmacro simple-let (bindings &body body)
+ (let ((vars (mapcar (lambda (x) (if (atom x) x (first x))) bindings))
+ (vals (mapcar (lambda (x) (if (or (atom x) (endp (cdr x))) nil (second x))) bindings)))
+ (let ((gensyms (mapcar (lambda (x) (ps-gensym (format nil "_js_~a" x))) vars)))
+ `(simple-let* ,(mapcar #'list gensyms vals)
+ (simple-let* ,(mapcar #'list vars gensyms)
+ ,@(mapcar (lambda (x) `(delete ,x)) gensyms)
+ ,@body)))))
+
(defpsmacro let* (bindings &body body)
`(simple-let* ,bindings ,@body))
-(defpsmacro let (&rest stuff)
- "Right now, let doesn't do parallel assignment."
- `(let* ,@stuff))
+(defpsmacro let (bindings &body body)
+ `(simple-let ,bindings ,@body))
(define-ps-special-form let1 (expecting binding &rest body)
(ecase expecting
(try (progn (setf ,temp-stack-var ,var)
(setf ,var ,value)
,@body)
- (:finally (setf ,var ,temp-stack-var))))))
+ (:finally
+ (setf ,var ,temp-stack-var)
+ (delete ,temp-stack-var))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; iteration
-(defun make-for-vars (decls)
- (loop for decl in decls
- for var = (if (atom decl) decl (first decl))
- for init-value = (if (atom decl) nil (second decl))
- collect (cons (compile-parenscript-form var :expecting :symbol) (compile-parenscript-form init-value))))
-
-(defun make-for-steps (decls)
- (loop for decl in decls
- when (= (length decl) 3)
- collect (compile-parenscript-form (third decl) :expecting :expression)))
-
-(define-ps-special-form do (expecting decls termination-test &rest body)
- (declare (ignore expecting))
- (let ((vars (make-for-vars decls))
- (steps (make-for-steps decls))
- (test (compile-parenscript-form `(not ,(first termination-test)) :expecting :expression))
- (body (compile-parenscript-form `(progn ,@body))))
- (list 'js-for vars steps test body)))
+(defun make-for-vars/inits (init-forms)
+ (mapcar (lambda (x)
+ (cons (compile-parenscript-form (if (atom x) x (first x)) :expecting :symbol)
+ (compile-parenscript-form (if (atom x) nil (second x)))))
+ init-forms))
-(define-ps-special-form doeach (expecting decl &rest body)
+(define-ps-special-form labeled-for (expecting label init-forms cond-forms step-forms &rest body)
+ (declare (ignore expecting))
+ (let ((vars (make-for-vars/inits init-forms))
+ (steps (mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) step-forms))
+ (tests (mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) cond-forms))
+ (body (compile-parenscript-form `(progn ,@body))))
+ (list 'js-for label vars tests steps body)))
+
+(defpsmacro for (init-forms cond-forms step-forms &body body)
+ `(labeled-for nil ,init-forms ,cond-forms ,step-forms ,@body))
+
+(defun do-make-let-bindings (decls)
+ (mapcar (lambda (x)
+ (if (atom x) x
+ (if (endp (cdr x)) (list (car x))
+ (subseq x 0 2))))
+ decls))
+
+(defun do-make-init-vars (decls)
+ (mapcar (lambda (x) (if (atom x) x (first x))) decls))
+
+(defun do-make-init-vals (decls)
+ (mapcar (lambda (x) (if (or (atom x) (endp (cdr x))) nil (second x))) decls))
+
+(defun do-make-for-vars/init (decls)
+ (mapcar (lambda (x)
+ (if (atom x) x
+ (if (endp (cdr x)) x
+ (subseq x 0 2))))
+ decls))
+
+(defun do-make-for-steps (decls)
+ (mapcar (lambda (x)
+ `(setf ,(first x) ,(third x)))
+ (remove-if (lambda (x) (or (atom x) (< (length x) 3))) decls)))
+
+(defun do-make-iter-psteps (decls)
+ `(psetq
+ ,@(mapcan (lambda (x) (list (first x) (third x)))
+ (remove-if (lambda (x) (or (atom x) (< (length x) 3))) decls))))
+
+(defpsmacro do* (decls (termination &optional (result nil result?)) &body body)
+ (if result?
+ `((lambda ()
+ (for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
+ ,@body)
+ (return ,result)))
+ `(progn
+ (for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
+ ,@body))))
+
+(defpsmacro do (decls (termination &optional (result nil result?)) &body body)
+ (if result?
+ `((lambda ,(do-make-init-vars decls)
+ (for () ((not ,termination)) ()
+ ,@body
+ ,(do-make-iter-psteps decls))
+ (return ,result))
+ ,@(do-make-init-vals decls))
+ `(let ,(do-make-let-bindings decls)
+ (for () ((not ,termination)) ()
+ ,@body
+ ,(do-make-iter-psteps decls)))))
+
+(define-ps-special-form for-in (expecting decl &rest body)
(declare (ignore expecting))
- (list 'js-for-each
- (first decl)
+ (list 'js-for-in
+ (compile-parenscript-form (first decl) :expecting :expression)
(compile-parenscript-form (second decl) :expecting :expression)
- (compile-parenscript-form `(progn ,@body))))
+ (compile-parenscript-form `(progn ,@body))))
+
+(defpsmacro doeach ((var array &optional (result (values) result?)) &body body)
+ "Iterates over `array'. If `var' is a symbol, binds `var' to each
+element key. If `var' is a list, it must be a list of two
+symbols, (key value), which will be bound to each successive key/value
+pair in `array'."
+ (if result?
+ (if (consp var)
+ (destructuring-bind (key val) var
+ `((lambda ()
+ (let* (,val)
+ (for-in ((var ,key) ,array)
+ (setf ,val (aref ,array ,key))
+ ,@body)
+ (return ,result)))))
+ `((lambda ()
+ (for-in ((var ,var) ,array)
+ ,@body)
+ (return ,result))))
+ (if (consp var)
+ (destructuring-bind (key val) var
+ `(progn
+ (let* (,val)
+ (for-in ((var ,key) ,array)
+ (setf ,val (aref ,array ,key))
+ ,@body))))
+ `(progn
+ (for-in ((var ,var) ,array) ,@body)))))
(define-ps-special-form while (expecting test &rest body)
(declare (ignore expecting))
(list 'js-while (compile-parenscript-form test :expecting :expression)
(compile-parenscript-form `(progn ,@body))))
-(defpsmacro dotimes (iter &rest body)
- (let ((var (first iter))
- (times (second iter)))
- `(do ((,var 0 (1+ ,var)))
- ((>= ,var ,times))
- ,@body)))
-
-(defpsmacro dolist (i-array &rest body)
- (let ((var (first i-array))
- (array (second i-array))
- (arrvar (ps-gensym "tmp-arr"))
- (idx (ps-gensym "tmp-i")))
- `(let* ((,arrvar ,array))
- (do ((,idx 0 (1+ ,idx)))
- ((>= ,idx (slot-value ,arrvar 'length)))
- (let* ((,var (aref ,arrvar ,idx)))
- ,@body)))))
+(defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
+ `(do* ((,var 0 (1+ ,var)))
+ ((>= ,var ,count) ,@(when result? (list result)))
+ ,@body))
+
+(defpsmacro dolist ((var array &optional (result nil result?)) &body body)
+ (let ((idx (ps-gensym "_js_idx"))
+ (arrvar (ps-gensym "_js_arrvar")))
+ `(do* (,var
+ (,arrvar ,array)
+ (,idx 0 (1+ ,idx)))
+ ((>= ,idx (slot-value ,arrvar 'length))
+ ,@(when result? (list result)))
+ (setq ,var (aref ,arrvar ,idx))
+ ,@body)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; misc
(define-ps-special-form with (expecting expression &rest body)
(declare (ignore expecting))
(list 'js-with (compile-parenscript-form expression :expecting :expression)
- (compile-parenscript-form `(progn ,@body))))
+ (compile-parenscript-form `(progn ,@body))))
(define-ps-special-form try (expecting form &rest clauses)
(declare (ignore expecting))
HCoop / clinton / parenscript.git / blobdiff