;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)))))
(!== '===)
(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
(let ((clauses (mapcar (lambda (clause)
(let ((val (car clause))
(body (cdr clause)))
- (cons (if (eql val 'default)
+ (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))
(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)
(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 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))
HCoop / clinton / parenscript.git / blobdiff