-(in-package :parenscript)
+(in-package "PARENSCRIPT")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 ()
+ (list 'js:literal ,string))))
(defpsliteral this "this")
(defpsliteral t "true")
(macrolet ((def-for-literal (name printer)
`(progn
- (pushnew ',name *ps-literals*)
- (define-ps-special-form ,name (expecting &optional label)
- (declare (ignore expecting))
+ (add-ps-literal ',name)
+ (define-ps-special-form ,name (&optional label)
(list ',printer label)))))
- (def-for-literal break js-break)
- (def-for-literal continue js-continue))
+ (def-for-literal break js:break)
+ (def-for-literal continue js:continue))
+
+(defpsmacro quote (x)
+ (typecase x
+ (cons (cons 'array (mapcar (lambda (x) `',x) x)))
+ (null '(array))
+ (symbol (symbol-to-js-string x))
+ (number x)
+ (string x)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 (x)
+ (list 'js: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 (&optional value)
+ `(js:return ,(compile-parenscript-form value :expecting :expression)))
-(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 (value)
+ `(js:throw ,(compile-parenscript-form value :expecting :expression)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; arrays
-(define-ps-special-form array (expecting &rest values)
- (declare (ignore expecting))
- (cons 'array-literal (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression))
+(define-ps-special-form array (&rest values)
+ `(js:array ,@(mapcar (lambda (form) (compile-parenscript-form form :expecting :expression))
values)))
-(define-ps-special-form aref (expecting array &rest coords)
- (declare (ignore expecting))
- (list 'js-aref (compile-parenscript-form array :expecting :expression)
- (mapcar (lambda (form)
- (compile-parenscript-form form :expecting :expression))
- coords)))
-
-(define-ps-special-form {} (expecting &rest arrows)
- (declare (ignore expecting))
- (cons 'object-literal (loop for (key value) on arrows by #'cddr
- collect (cons key (compile-parenscript-form value :expecting :expression)))))
+(define-ps-special-form aref (array &rest coords)
+ `(js:aref ,(compile-parenscript-form array :expecting :expression)
+ ,(mapcar (lambda (form)
+ (compile-parenscript-form form :expecting :expression))
+ coords)))
(defpsmacro list (&rest values)
`(array ,@values))
-(defpsmacro make-array (&rest inits)
- `(new (*array ,@inits)))
+(defpsmacro make-array (&rest initial-values)
+ `(new (*array ,@initial-values)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; operators
-(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 '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 '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 'operator '- (mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
- (cons first rest)))))
-
-(define-ps-special-form not (expecting x)
- (declare (ignore expecting))
+(define-ps-special-form incf (x &optional (delta 1))
+ (if (eql delta 1)
+ `(js:unary-operator js:++ ,(compile-parenscript-form x :expecting :expression) :prefix t)
+ `(js:operator js:+= ,(compile-parenscript-form x :expecting :expression)
+ ,(compile-parenscript-form delta :expecting :expression))))
+
+(define-ps-special-form decf (x &optional (delta 1))
+ (if (eql delta 1)
+ `(js:unary-operator js:-- ,(compile-parenscript-form x :expecting :expression) :prefix t)
+ `(js:operator js:-= ,(compile-parenscript-form x :expecting :expression)
+ ,(compile-parenscript-form delta :expecting :expression))))
+
+(define-ps-special-form - (first &rest rest)
+ (if rest
+ `(js:operator js:- ,@(mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
+ (cons first rest)))
+ `(js:unary-operator js:- ,(compile-parenscript-form first :expecting :expression) :prefix t)))
+
+(define-ps-special-form not (x)
(let ((form (compile-parenscript-form x :expecting :expression))
- (not-op nil))
- (if (and (eql (first form) 'operator)
- (= (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))
+ inverse-op)
+ (if (and (eq (car form) 'js:operator)
+ (= (length (cddr form)) 2)
+ (setf inverse-op (case (cadr form)
+ (== '!=)
+ (< '>=)
+ (> '<=)
+ (<= '>)
+ (>= '<)
+ (!= '==)
+ (=== '!==)
+ (!== '===))))
+ `(js:operator ,inverse-op ,@(cddr form))
+ `(js:unary-operator js:! ,form :prefix t))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; control structures
(defun flatten-blocks (body)
(when body
(if (and (listp (car body))
- (eql 'js-block (caar body)))
+ (eq 'js:block (caar body)))
(append (third (car body)) (flatten-blocks (cdr body)))
(cons (car body) (flatten-blocks (cdr body))))))
(or (numberp form)
(stringp form)
(and (listp form)
- (eql 'js-literal (car form)))))
+ (eq 'js:literal (car form)))))
-(define-ps-special-form progn (expecting &rest body)
- (if (and (eql expecting :expression) (= 1 (length body)))
+(define-ps-special-form progn (&rest body)
+ (if (and (eq expecting :expression) (= 1 (length body)))
(compile-parenscript-form (car body) :expecting :expression)
- (list 'js-block
- expecting
- (let* ((block (mapcar (lambda (form)
- (compile-parenscript-form form :expecting expecting))
- body))
- (clean-block (remove nil block))
- (flat-block (flatten-blocks clean-block))
- (reachable-block (append (remove-if #'constant-literal-form-p (butlast flat-block))
- (last flat-block))))
- reachable-block))))
-
-(define-ps-special-form cond (expecting &rest clauses)
+ `(js:block
+ ,expecting
+ ,(let* ((block (flatten-blocks (remove nil (mapcar (lambda (form)
+ (compile-parenscript-form form :expecting expecting))
+ body)))))
+ (append (remove-if #'constant-literal-form-p (butlast block)) (last block))))))
+
+(define-ps-special-form cond (&rest clauses)
(ecase expecting
- (:statement (list 'js-cond-statement
- (mapcar (lambda (clause)
- (destructuring-bind (test &rest body)
- clause
- (list (compile-parenscript-form test :expecting :expression)
- (compile-parenscript-form `(progn ,@body) :expecting :statement))))
- clauses)))
+ (:statement `(js:cond ,(mapcar (lambda (clause)
+ (destructuring-bind (test &rest body)
+ clause
+ (list (compile-parenscript-form test :expecting :expression)
+ (compile-parenscript-form `(progn ,@body) :expecting :statement))))
+ clauses)))
(:expression (make-cond-clauses-into-nested-ifs clauses))))
(defun make-cond-clauses-into-nested-ifs (clauses)
(car clauses)
(if (eq t test)
(compile-parenscript-form `(progn ,@body) :expecting :expression)
- (list 'js-expression-if (compile-parenscript-form test :expecting :expression)
- (compile-parenscript-form `(progn ,@body) :expecting :expression)
- (make-cond-clauses-into-nested-ifs (cdr clauses)))))
- (compile-parenscript-form nil :expecting :expression)))
+ `(js:? ,(compile-parenscript-form test :expecting :expression)
+ ,(compile-parenscript-form `(progn ,@body) :expecting :expression)
+ ,(make-cond-clauses-into-nested-ifs (cdr clauses)))))
+ (compile-parenscript-form nil :expecting :expression))) ;; js:null
-(define-ps-special-form if (expecting test then &optional else)
+(define-ps-special-form if (test then &optional else)
(ecase expecting
- (:statement (list 'js-statement-if (compile-parenscript-form test :expecting :expression)
- (compile-parenscript-form `(progn ,then))
- (when else (compile-parenscript-form `(progn ,else)))))
- (:expression (list 'js-expression-if (compile-parenscript-form test :expecting :expression)
- (compile-parenscript-form then :expecting :expression)
- (compile-parenscript-form else :expecting :expression)))))
-
-(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))
- (mapcar (lambda (statement) (compile-parenscript-form statement :expecting :statement))
- body))))
- clauses))
- (expr (compile-parenscript-form test-expr :expecting :expression)))
- (list 'js-switch expr clauses)))
+ (:statement `(js:if ,(compile-parenscript-form test :expecting :expression)
+ ,(compile-parenscript-form `(progn ,then))
+ ,(when else (compile-parenscript-form `(progn ,else)))))
+ (:expression `(js:? ,(compile-parenscript-form test :expecting :expression)
+ ,(compile-parenscript-form then :expecting :expression)
+ ,(compile-parenscript-form else :expecting :expression)))))
+
+(define-ps-special-form switch (test-expr &rest clauses)
+ `(js:switch ,(compile-parenscript-form test-expr :expecting :expression)
+ ,(loop for (val . body) in clauses collect
+ (cons (if (and (symbolp val) (eq (ensure-ps-symbol val) 'default))
+ 'default
+ (compile-parenscript-form val :expecting :expression))
+ (mapcar (lambda (x) (compile-parenscript-form x :expecting :statement))
+ body)))))
(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))
;; the first compilation will produce a list of variables we need to declare in the function body
(compile-parenscript-form `(progn ,@body) :expecting :statement)
;; now declare and compile
- (compile-parenscript-form `(progn ,@(loop for var in *enclosing-lexical-block-declarations* collect `(var ,var))
- ,@body) :expecting :statement))))
+ (compile-parenscript-form `(progn
+ ,@(mapcar (lambda (var) `(var ,var)) *enclosing-lexical-block-declarations*)
+ ,@body)
+ :expecting :statement))))
-(define-ps-special-form %js-lambda (expecting args &rest body)
- (declare (ignore expecting))
- (cons 'js-lambda (compile-function-definition args body)))
+(define-ps-special-form %js-lambda (args &rest body)
+ `(js:lambda ,@(compile-function-definition args body)))
-(define-ps-special-form %js-defun (expecting name args &rest body)
- (declare (ignore expecting))
- (append (list 'js-defun name) (compile-function-definition args body)))
+(define-ps-special-form %js-defun (name args &rest body)
+ `(js:defun ,name ,@(compile-function-definition args body)))
(defun parse-function-body (body)
(let* ((docstring
(values body-forms docstring)))
(defun parse-key-spec (key-spec)
- "parses an &key parameter. Returns 4 values:
+ "parses an &key parameter. Returns 5 values:
var, init-form, keyword-name, supplied-p-var, init-form-supplied-p.
Syntax of key spec:
(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
;; * optional variables' variable names are mapped directly into the lambda list,
;; and for each optional variable with name v and default value d, a form is produced
;; (defaultf v d)
- ;; * when any keyword variables are in the lambda list, a single 'optional-args' variable is
- ;; appended to the js-lambda list as the last argument. WITH-SLOTS is used for all
- ;; the variables with inside the body of the function,
- ;; a (with-slots ((var-name key-name)) optional-args ...)
+ ;; * keyword variables are not included in the js-lambda list, but instead are
+ ;; obtained from the magic js ARGUMENTS pseudo-array. Code assigning values to
+ ;; keyword vars is prepended to the body of the function.
(declare (ignore name))
(multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? aux
more? more-context more-count key-object)
(parse-lambda-list lambda-list)
- (declare (ignore allow? aux? aux more? more-context more-count))
- (let* ((options-var (or key-object (ps-gensym)))
- ;; optionals are of form (var default-value)
+ (declare (ignore allow? aux? aux more? more-context more-count key-object))
+ (let* (;; optionals are of form (var default-value)
(effective-args
(remove-if
#'null
(append requireds
- (mapcar #'parse-optional-spec optionals)
- (when keys (list options-var)))))
- ;; an alist of arg -> default val
- (initform-pairs
- (remove
- nil
- (append
- ;; optional arguments first
- (mapcar #'(lambda (opt-spec)
- (multiple-value-bind (var val) (parse-optional-spec opt-spec)
- (cons var val)))
- optionals)
- (if keys? (list (cons options-var '(create))))
- (mapcar #'(lambda (key-spec)
- (multiple-value-bind (var val x y specified?) (parse-key-spec key-spec)
- (declare (ignore x y))
- (when specified? (cons var val))))
- keys))))
- (body-paren-forms (parse-function-body body)) ;remove documentation
- ;;
- (initform-forms
- (mapcar #'(lambda (default-pair)
- `(defaultf ,(car default-pair) ,(cdr default-pair)))
- initform-pairs))
+ (mapcar #'parse-optional-spec optionals))))
+ (opt-forms
+ (mapcar #'(lambda (opt-spec)
+ (multiple-value-bind (var val) (parse-optional-spec opt-spec)
+ `(defaultf ,var ,val)))
+ optionals))
+ (key-forms
+ (when keys?
+ (with-ps-gensyms (n)
+ (let ((decls nil) (assigns nil) (defaults nil))
+ (mapc (lambda (k)
+ (multiple-value-bind (var init-form keyword)
+ (parse-key-spec k)
+ (push (list 'var var) decls)
+ (push `(,keyword (setf ,var (aref arguments (1+ ,n)))) assigns)
+ (push (list 'defaultf var init-form) defaults)))
+ (reverse keys))
+ `(,@decls
+ (loop :for ,n :from ,(length requireds)
+ :below (length arguments) :by 2 :do
+ (case (aref arguments ,n) ,@assigns))
+ ,@defaults)))))
(rest-form
(if rest?
(with-ps-gensyms (i)
`(progn (var ,rest (array))
- (dotimes (,i (- arguments.length ,(length effective-args)))
+ (dotimes (,i (- (slot-value arguments 'length) ,(length effective-args)))
(setf (aref ,rest ,i) (aref arguments (+ ,i ,(length effective-args)))))))
`(progn)))
- (effective-body (append initform-forms (list rest-form) body-paren-forms))
- (effective-body
- (if keys?
- (list `(with-slots ,(mapcar #'(lambda (key-spec)
- (multiple-value-bind (var x key-name)
- (parse-key-spec key-spec)
- (declare (ignore x))
- (list var key-name)))
- keys)
- ,options-var
- ,@effective-body))
- effective-body)))
+ (body-paren-forms (parse-function-body body)) ; remove documentation
+ (effective-body (append opt-forms key-forms (list rest-form) body-paren-forms)))
(values effective-args effective-body))))
(defpsmacro defun (name lambda-list &body body)
[&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))))
`(%js-lambda ,effective-args
,@effective-body)))
+(defpsmacro flet (fn-defs &rest body)
+ (flet ((process-fn-def (def)
+ `(var ,(car def) (lambda ,@(cdr def)))))
+ `(progn ,@(mapcar #'process-fn-def fn-defs) ,@body)))
+
+(defpsmacro labels (fn-defs &rest body)
+ (flet ((process-fn-def (def)
+ `(var ,(car def) (defun ,(car def) ,@(cdr def)))))
+ `(progn ,@(mapcar #'process-fn-def fn-defs) ,@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)
(defpsmacro defsetf (access-fn &rest args)
`(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
+(defpsmacro funcall (&rest arg-form)
+ arg-form)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)
- (declare (ignore expecting))
+(define-ps-special-form macrolet (macros &body body)
(with-temp-macro-environment (macro-env-dict)
(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 (eval (make-ps-macro-function arglist body))))))
(compile-parenscript-form `(progn ,@body))))
-(define-ps-special-form symbol-macrolet (expecting symbol-macros &body body)
- (declare (ignore expecting))
+(define-ps-special-form symbol-macrolet (symbol-macros &body body)
(with-temp-macro-environment (macro-env-dict)
(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 (lambda (x) (declare (ignore x)) 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-special-form defmacro (name args &body body) ;; should this be a macro?
+ (eval `(defpsmacro ,name ,args ,@body))
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-special-form define-symbol-macro (name expansion) ;; should this be a macro?
+ (eval `(define-ps-symbol-macro ,name ,expansion))
nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; objects
-(define-ps-special-form create (expecting &rest args)
- (declare (ignore expecting))
- (list 'js-object (loop for (name val) on args by #'cddr collecting
- (let ((name-expr (compile-parenscript-form name :expecting :expression)))
- (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)))))
- ()
- "Slot ~s is not one of js-variable, keyword, string or number." name-expr)
- (list name-expr (compile-parenscript-form val :expecting :expression))))))
-
-(define-ps-special-form %js-slot-value (expecting obj slot)
- (declare (ignore expecting))
- (if (ps::ps-macroexpand slot)
- (list 'js-slot-value (compile-parenscript-form obj :expecting :expression) (compile-parenscript-form slot))
- (compile-parenscript-form obj :expecting :expression)))
-
-(define-ps-special-form instanceof (expecting value type)
- (declare (ignore expecting))
- (list 'js-instanceof (compile-parenscript-form value :expecting :expression)
- (compile-parenscript-form type :expecting :expression)))
+(add-ps-literal '{})
+(define-ps-symbol-macro {} (create))
+
+(define-ps-special-form create (&rest arrows)
+ `(js:object ,@(loop for (key-expr val-expr) on arrows by #'cddr collecting
+ (let ((key (compile-parenscript-form key-expr :expecting :expression)))
+ (when (keywordp key)
+ (setf key `(js:variable ,key)))
+ (assert (or (stringp key)
+ (numberp key)
+ (and (listp key)
+ (or (eq 'js:variable (car key))
+ (eq 'quote (car key)))))
+ ()
+ "Slot key ~s is not one of js-variable, keyword, string or number." key)
+ (cons key (compile-parenscript-form val-expr :expecting :expression))))))
+
+(define-ps-special-form %js-slot-value (obj slot)
+ `(js:slot-value ,(compile-parenscript-form obj :expecting :expression)
+ ,(if (and (listp slot) (eq 'quote (car slot)))
+ (second slot) ;; assume we're quoting a symbol
+ (compile-parenscript-form slot))))
+
+(define-ps-special-form instanceof (value type)
+ `(js:instanceof ,(compile-parenscript-form value :expecting :expression)
+ ,(compile-parenscript-form type :expecting :expression)))
(defpsmacro slot-value (obj &rest slots)
(if (null (rest slots))
(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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(/ '/=)
(t nil)))
-(defun smart-setf (lhs rhs)
- (if (and (listp rhs)
- (eql 'operator (car rhs))
- (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) '(+ *))
- (equalp lhs (first (third rhs))))
- (list 'operator (assignment-op (second rhs))
- (list lhs (list 'operator (second rhs) args-without-first))))
- (t (list 'js-assign lhs rhs))))
- (list 'js-assign lhs rhs)))
-
-(define-ps-special-form setf1% (expecting lhs rhs)
- (declare (ignore expecting))
- (smart-setf (compile-parenscript-form lhs :expecting :expression) (compile-parenscript-form rhs :expecting :expression)))
+(define-ps-special-form setf1% (lhs rhs)
+ (let ((lhs (compile-parenscript-form lhs :expecting :expression))
+ (rhs (compile-parenscript-form rhs :expecting :expression)))
+ (if (and (listp rhs)
+ (eq 'js:operator (car rhs))
+ (member (cadr rhs) '(+ *))
+ (equalp lhs (caddr rhs)))
+ `(js:operator ,(assignment-op (cadr rhs)) ,lhs (js:operator ,(cadr rhs) ,@(cdddr rhs)))
+ `(js:= ,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)))))
-(define-ps-special-form var (expecting name &rest value)
- (declare (ignore expecting))
- (append (list 'js-var name)
- (when value
- (assert (= (length value) 1) () "Wrong number of arguments to var: ~s" `(var ,name ,@value))
- (list (compile-parenscript-form (car value) :expecting :expression)))))
+(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))))))
-(defpsmacro defvar (name &rest value)
+(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 (name &optional (value (values) value-provided?) documentation)
+ (declare (ignore documentation))
+ `(js:var ,name ,@(when value-provided?
+ (list (compile-parenscript-form value :expecting :expression)))))
+
+(defpsmacro defvar (name &optional (value (values) value-provided?) documentation)
"Note: this must be used as a top-level form, otherwise the result will be undefined behavior."
(pushnew name *ps-special-variables*)
- (assert (or (null value) (= (length value) 1)) () "Wrong number of arguments to defvar: ~s" `(defvar ,name ,@value))
- `(var ,name ,@value))
+ `(var ,name ,@(when value-provided? (list value))))
(defun make-let-vars (bindings)
(mapcar (lambda (x) (if (listp x) (car x) x)) bindings))
(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)
+ `(,(if (= 1 (length bindings)) 'simple-let* 'simple-let) ,bindings ,@body))
-(define-ps-special-form let1 (expecting binding &rest body)
+(define-ps-special-form let1 (binding &rest body)
(ecase expecting
(:statement
(compile-parenscript-form `(progn ,(if (atom binding) `(var ,binding) `(var ,@binding)) ,@body) :expecting :statement))
(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)))
-
-(define-ps-special-form doeach (expecting decl &rest body)
- (declare (ignore expecting))
- (list 'js-for-each
- (first decl)
- (compile-parenscript-form (second decl) :expecting :expression)
- (compile-parenscript-form `(progn ,@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)))))
+(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)) :expecting :expression)))
+ init-forms))
+
+(define-ps-special-form labeled-for (label init-forms cond-forms step-forms &rest body)
+ `(js:for ,label
+ ,(make-for-vars/inits init-forms)
+ ,(mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) cond-forms)
+ ,(mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) step-forms)
+ ,(compile-parenscript-form `(progn ,@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 ((var object) &rest body)
+ `(js:for-in ,(compile-parenscript-form `(var ,var) :expecting :expression)
+ ,(compile-parenscript-form object :expecting :expression)
+ ,(compile-parenscript-form `(progn ,@body))))
+
+(define-ps-special-form while (test &rest body)
+ `(js:while ,(compile-parenscript-form test :expecting :expression)
+ ,(compile-parenscript-form `(progn ,@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))))
+(define-ps-special-form with (expression &rest body)
+ `(js:with ,(compile-parenscript-form expression :expecting :expression)
+ ,(compile-parenscript-form `(progn ,@body))))
-(define-ps-special-form try (expecting form &rest clauses)
- (declare (ignore expecting))
+(define-ps-special-form try (form &rest clauses)
(let ((catch (cdr (assoc :catch clauses)))
(finally (cdr (assoc :finally clauses))))
(assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
(assert (or catch finally) ()
"Try form should have either a catch or a finally clause or both.")
- (list 'js-try (compile-parenscript-form `(progn ,form))
- :catch (when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
+ `(js:try ,(compile-parenscript-form `(progn ,form))
+ :catch ,(when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
(compile-parenscript-form `(progn ,@(cdr catch)))))
- :finally (when finally (compile-parenscript-form `(progn ,@finally))))))
-
-(define-ps-special-form cc-if (expecting test &rest body)
- (declare (ignore expecting))
- (list 'cc-if test (mapcar #'compile-parenscript-form body)))
-
-(define-ps-special-form regex (expecting regex)
- (declare (ignore expecting))
- (list 'js-regex (string regex)))
-
-(defpsmacro lisp (&body forms)
- "Evaluates the given forms in Common Lisp at ParenScript
-macro-expansion time. The value of the last form is treated as a
-ParenScript expression and is inserted into the generated Javascript
-\(use nil for no-op)."
- (eval (cons 'progn forms)))
+ :finally ,(when finally (compile-parenscript-form `(progn ,@finally))))))
+
+(define-ps-special-form cc-if (test &rest body)
+ `(js:cc-if ,test ,@(mapcar #'compile-parenscript-form body)))
+
+(define-ps-special-form regex (regex)
+ `(js:regex ,(string regex)))
+
+(define-ps-special-form lisp (lisp-form)
+ ;; (ps (foo (lisp bar))) is in effect equivalent to (ps* `(foo ,bar))
+ ;; when called from inside of ps*, lisp-form has access only to the dynamic environment (like for eval)
+ `(js:escape ,(ps1* lisp-form)))
HCoop / clinton / parenscript.git / blobdiff