lines.pop(0)
self.lineCounter += 1
continue
- elif self.figureRe.match(line):
+ elif self.figureRe.match(line):
line = lines.pop(0)
self.doFigure(line)
- self.lineCounter += 1
- elif self.escapeRe.match(line):
+ self.lineCounter += 1
+ elif self.escapeRe.match(line):
line = lines.pop(0)
self.doEscape(line)
- self.lineCounter += 1
+ self.lineCounter += 1
elif self.headingRe.match(line):
line = lines.pop(0)
self.doHeading(line)
"True if there is a Parenscript macro named by the symbol NAME."
(and (symbolp name)
(let ((macro-spec (lookup-macro-spec name environment)))
- (and macro-spec (not (car macro-spec))))))
+ (and macro-spec (not (car macro-spec))))))
(defun lookup-macro-expansion-function (name &optional (environment *script-macro-env*))
"Lookup NAME in the given macro expansion environment (which
(defmacro defmacro/ps (name args &body body)
"Define a Lisp macro and import it into the ParenScript macro environment."
`(progn (defmacro ,name ,args ,@body)
- (ps:import-macros-from-lisp ',name)))
+ (ps:import-macros-from-lisp ',name)))
(defmacro defmacro+ps (name args &body body)
"Define a Lisp macro and a ParenScript macro in their respective
Javascript arguments. The only extra processing this does is makes :keyword arguments
into a single options argument via CREATE."
(flet ((keyword-arg (arg)
- "If the given compiled expression is supposed to be a keyword argument, returns
+ "If the given compiled expression is supposed to be a keyword argument, returns
the keyword for it."
- (when (and (listp arg) (eql (first arg) 'script-quote)) (second arg))))
+ (when (and (listp arg) (eql (first arg) 'script-quote)) (second arg))))
(let ((compiled-args (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :expression))
arg-forms)))
(do ((effective-expressions nil)
(defmethod compile-parenscript-form ((form cons) &key (expecting :statement))
(let* ((name (car form))
- (args (cdr form)))
+ (args (cdr form)))
(cond ((eql name 'quote)
(assert (= 1 (length args)) () "Wrong number of arguments to quote: ~s" args)
(list 'script-quote (first args)))
(defun collect-list-expander (n-value n-tail forms)
(let ((n-res (gensym)))
`(progn
- ,@(mapcar (lambda (form)
- `(let ((,n-res (cons ,form nil)))
- (cond (,n-tail
- (setf (cdr ,n-tail) ,n-res)
- (setq ,n-tail ,n-res))
- (t
- (setq ,n-tail ,n-res ,n-value ,n-res)))))
- forms)
- ,n-value))))
+ ,@(mapcar (lambda (form)
+ `(let ((,n-res (cons ,form nil)))
+ (cond (,n-tail
+ (setf (cdr ,n-tail) ,n-res)
+ (setq ,n-tail ,n-res))
+ (t
+ (setq ,n-tail ,n-res ,n-value ,n-res)))))
+ forms)
+ ,n-value))))
(defmacro collect (collections &body body)
(let ((macros ())
- (binds ()))
+ (binds ()))
(dolist (spec collections)
- ; (unless (proper-list-of-length-p spec 1 3)
- ; (error "malformed collection specifier: ~S" spec))
+ ; (unless (proper-list-of-length-p spec 1 3)
+ ; (error "malformed collection specifier: ~S" spec))
(let* ((name (first spec))
- (default (second spec))
- (kind (or (third spec) 'collect))
- (n-value (gensym (concatenate 'string
- (symbol-name name)
- "-N-VALUE-"))))
- (push `(,n-value ,default) binds)
- (if (eq kind 'collect)
- (let ((n-tail (gensym (concatenate 'string
- (symbol-name name)
- "-N-TAIL-"))))
- (if default
- (push `(,n-tail (last ,n-value)) binds)
- (push n-tail binds))
- (push `(,name (&rest args)
- (collect-list-expander ',n-value ',n-tail args))
- macros))
- (push `(,name (&rest args)
- (collect-normal-expander ',n-value ',kind args))
- macros))))
+ (default (second spec))
+ (kind (or (third spec) 'collect))
+ (n-value (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-VALUE-"))))
+ (push `(,n-value ,default) binds)
+ (if (eq kind 'collect)
+ (let ((n-tail (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-TAIL-"))))
+ (if default
+ (push `(,n-tail (last ,n-value)) binds)
+ (push n-tail binds))
+ (push `(,name (&rest args)
+ (collect-list-expander ',n-value ',n-tail args))
+ macros))
+ (push `(,name (&rest args)
+ (collect-normal-expander ',n-value ',kind args))
+ macros))))
`(macrolet ,macros (let* ,(nreverse binds) ,@body))))
(defparameter *lambda-list-keywords*
(keyp nil)
(auxp nil)
(allowp nil)
- (key-object nil)
+ (key-object nil)
(state :required))
(declare (type (member :allow-other-keys :aux
:key
:optional
:post-more :post-rest
:required :rest
- :key-object :post-key)
+ :key-object :post-key)
state))
(dolist (arg list)
(if (member arg *lambda-list-keywords*)
(&optional
(unless (eq state :required)
(format t "misplaced &OPTIONAL in lambda list: ~S"
- list))
+ list))
(setq state :optional))
(&rest
(unless (member state '(:required :optional))
(format t "multiple &AUX in lambda list: ~S" list))
(setq auxp t
state :aux))
- (&key-object
- (unless (member state '(:key :allow-other-keys))
- (format t "&key-object misplaced in lmabda list: ~S. Belongs after &key" list))
- (setf state :key-object))
+ (&key-object
+ (unless (member state '(:key :allow-other-keys))
+ (format t "&key-object misplaced in lmabda list: ~S. Belongs after &key" list))
+ (setf state :key-object))
(t (format t "unknown LAMBDA-LIST-KEYWORD in lambda list: ~S." arg)))
(progn
(when (symbolp arg)
(setq more-count arg
state :post-more))
(:key (keys arg))
- (:key-object (setf key-object arg) (setf state :post-key))
+ (:key-object (setf key-object arg) (setf state :post-key))
(:aux (aux arg))
(t
(format t "found garbage in lambda list when expecting ~
(values (required) (optional) restp rest keyp (keys) allowp auxp (aux)
morep more-context more-count
(not (eq state :required))
- key-object))))
+ key-object))))
;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument
;;; really *is* a lambda list, not just a "lambda-list-like thing", so
(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)
(== '!=)
(< '>=)
(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 (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)))
+ clauses))
+ (expr (compile-parenscript-form test-expr :expecting :expression)))
(list 'js-switch expr clauses)))
(defpsmacro case (value &rest clauses)
(defpsmacro defaultf (place value)
`(setf ,place (or (and (=== undefined ,place) ,value)
- ,place)))
+ ,place)))
(defun parse-extended-function (lambda-list body &optional name)
"Returns two values: the effective arguments and body for a function with
(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)
(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)
(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
(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))
res)
((= i len)
(let ((split (if (> i last)
- (cons (subseq string last i) res)
- res)))
+ (cons (subseq string last i) res)
+ res)))
(nreverse (if remove-empty-subseqs
(delete "" split :test #'string-equal)
split))))
(setf symbol (symbol-name symbol)))
(let ((symbols (string-split symbol '(#\. #\[ #\]) :keep-separators t :remove-empty-subseqs t)))
(cond ((null symbols) "")
- ((= (length symbols) 1)
- (let (res
+ ((= (length symbols) 1)
+ (let (res
(do-not-touch nil)
- (lowercase t)
- (all-uppercase nil))
- (cond ((constant-string-p symbol)
- (setf all-uppercase t
- symbol (subseq symbol 1 (1- (length symbol)))))
- ((first-uppercase-p symbol)
- (setf lowercase nil
- symbol (subseq symbol 1)))
+ (lowercase t)
+ (all-uppercase nil))
+ (cond ((constant-string-p symbol)
+ (setf all-uppercase t
+ symbol (subseq symbol 1 (1- (length symbol)))))
+ ((first-uppercase-p symbol)
+ (setf lowercase nil
+ symbol (subseq symbol 1)))
((untouchable-string-p symbol)
(setf do-not-touch t
symbol (subseq symbol 1))))
- (flet ((reschar (c)
- (push (cond
+ (flet ((reschar (c)
+ (push (cond
(do-not-touch c)
((and lowercase (not all-uppercase))
(char-downcase c))
(t (char-upcase c)))
res)
- (setf lowercase t)))
- (dotimes (i (length symbol))
- (let ((c (char symbol i)))
- (cond
- ((eql c #\-)
- (setf lowercase (not lowercase)))
- ((assoc c *special-chars*)
- (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
- (reschar i)))
- (t (reschar c))))))
- (coerce (nreverse res) 'string)))
- (t (string-join (mapcar #'symbol-to-js symbols) "")))))
+ (setf lowercase t)))
+ (dotimes (i (length symbol))
+ (let ((c (char symbol i)))
+ (cond
+ ((eql c #\-)
+ (setf lowercase (not lowercase)))
+ ((assoc c *special-chars*)
+ (dolist (i (coerce (cdr (assoc c *special-chars*)) 'list))
+ (reschar i)))
+ (t (reschar c))))))
+ (coerce (nreverse res) 'string)))
+ (t (string-join (mapcar #'symbol-to-js symbols) "")))))
(defun ordered-set-difference (list1 list2 &key (test #'eql)) ;; because the CL set-difference may not preserve order
(reduce (lambda (list el) (remove el list :test test))
(test-ps-js method-call-string (.to-string "hi") "'hi'.toString()")
(test-ps-js method-call-lit-object
(.to-string (create :to-string (lambda ()
- (return "it works"))))
+ (return "it works"))))
"( { toString : function () { return 'it works'; } } ).toString()")
(test-ps-js method-call-variable
("u0080" . ,(code-char 128)) ;;Character over 127. Actually valid, parenscript escapes them to be sure.
("uABCD" . ,(code-char #xabcd)))));; Really above ascii.
(loop for (js-escape . lisp-char) in escapes
- for generated = (compile-script `(let* ((x ,(format nil "hello~ahi" lisp-char)))))
- for wanted = (format nil "var x = 'hello\\~ahi';" js-escape)
- do (is (string= (normalize-js-code generated) wanted)))))
+ for generated = (compile-script `(let* ((x ,(format nil "hello~ahi" lisp-char)))))
+ for wanted = (format nil "var x = 'hello\\~ahi';" js-escape)
+ do (is (string= (normalize-js-code generated) wanted)))))
(test-ps-js complicated-symbol-name1
grid-rows[foo].bar
(defmacro test-ps-js (testname parenscript javascript)
(let (
- ;; (parenscript
- ;; `(progn
- ;; (defpackage parenscript-test
- ;; (:lisp-package :parenscript-test))
- ;; ,parenscript)))
- )
+ ;; (parenscript
+ ;; `(progn
+ ;; (defpackage parenscript-test
+ ;; (:lisp-package :parenscript-test))
+ ;; ,parenscript)))
+ )
`(test ,testname ()
(setf ps:*ps-gensym-counter* 0)
HCoop / clinton / parenscript.git / commitdiff