src/ps-macrology.lisp

   1 (in-package :parenscript)
   2
   3 ;;;; The macrology of the Parenscript language.  Special forms and macros.
   4
   5 ;;; parenscript gensyms
   6 (defvar *ps-gensym-counter* 0)
   7
   8 (defun ps-gensym (&optional (prefix "_js"))
   9   (make-symbol (format nil "~A~A" prefix (incf *ps-gensym-counter*))))
  10
  11 (defmacro with-ps-gensyms (symbols &body body)
  12   "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers.
  13
  14 Each element of SYMBOLS is either a symbol or a list of (symbol
  15 gensym-prefix-string)."
  16   `(let* ,(mapcar (lambda (symbol)
  17                     (destructuring-bind (symbol &optional prefix)
  18                         (if (consp symbol)
  19                             symbol
  20                             (list symbol))
  21                       (if prefix
  22                           `(,symbol (ps-gensym ,prefix))
  23                           `(,symbol (ps-gensym)))))
  24                   symbols)
  25      ,@body))
  26
  27 (defun constant-literal-form-p (form)
  28   (or (numberp form)
  29       (stringp form)
  30       (and (listp form)
  31            (eql 'js-literal (car form)))))
  32
  33 (defpsmacro defaultf (place value)
  34   `(setf ,place (or (and (=== undefined ,place) ,value)
  35                  ,place)))
  36
  37 ;;; array literals
  38 (defpsmacro list (&rest values)
  39   `(array ,@values))
  40
  41 (defpsmacro make-array (&rest inits)
  42   `(new (*array ,@inits)))
  43
  44 ;;; slot access
  45 (defpsmacro slot-value (obj &rest slots)
  46   (if (null (rest slots))
  47       `(%js-slot-value ,obj ,(first slots))
  48       `(slot-value (slot-value ,obj ,(first slots)) ,@(rest slots))))
  49
  50 (defpsmacro with-slots (slots object &rest body)
  51   (flet ((slot-var (slot) (if (listp slot) (first slot) slot))
  52          (slot-symbol (slot) (if (listp slot) (second slot) slot)))
  53     `(symbol-macrolet ,(mapcar #'(lambda (slot)
  54                                    `(,(slot-var slot) (slot-value ,object ',(slot-symbol slot))))
  55                                slots)
  56       ,@body)))
  57
  58 (defpsmacro case (value &rest clauses)
  59   (labels ((make-clause (val body more)
  60              (cond ((listp val)
  61                     (append (mapcar #'list (butlast val))
  62                             (make-clause (first (last val)) body more)))
  63                    ((member val '(t otherwise))
  64                     (make-clause 'default body more))
  65                    (more `((,val ,@body break)))
  66                    (t `((,val ,@body))))))
  67     `(switch ,value ,@(mapcon (lambda (clause)
  68                                 (make-clause (car (first clause))
  69                                              (cdr (first clause))
  70                                              (rest clause)))
  71                               clauses))))
  72
  73 (define-ps-special-form let (expecting bindings &rest body)
  74   (declare (ignore expecting))
  75   (let ((defvars (mapcar (lambda (binding) (if (atom binding)
  76                                                `(defvar ,binding)
  77                                                `(defvar ,@binding)))
  78                          bindings)))
  79     (compile-parenscript-form `(progn ,@defvars ,@body))))
  80
  81 ;;; iteration
  82 (defpsmacro dotimes (iter &rest body)
  83   (let ((var (first iter))
  84         (times (second iter)))
  85   `(do ((,var 0 (1+ ,var)))
  86        ((>= ,var ,times))
  87      ,@body)))
  88
  89 (defpsmacro dolist (i-array &rest body)
  90   (let ((var (first i-array))
  91         (array (second i-array))
  92         (arrvar (ps-gensym "tmp-arr"))
  93         (idx (ps-gensym "tmp-i")))
  94     `(let ((,arrvar ,array))
  95       (do ((,idx 0 (1+ ,idx)))
  96           ((>= ,idx (slot-value ,arrvar 'length)))
  97         (let ((,var (aref ,arrvar ,idx)))
  98           ,@body)))))
  99
 100 ;;; macros
 101 (defmacro with-temp-macro-environment ((var) &body body)
 102   `(let* ((,var (make-macro-env-dictionary))
 103           (*script-macro-env* (cons ,var *script-macro-env*)))
 104     ,@body))
 105
 106 (define-ps-special-form macrolet (expecting macros &body body)
 107   (declare (ignore expecting))
 108   (with-temp-macro-environment (macro-env-dict)
 109     (dolist (macro macros)
 110       (destructuring-bind (name arglist &body body)
 111           macro
 112         (setf (get-macro-spec name macro-env-dict)
 113               (cons nil (make-ps-macro-function arglist body)))))
 114     (compile-parenscript-form `(progn ,@body))))
 115
 116 (define-ps-special-form symbol-macrolet (expecting symbol-macros &body body)
 117   (declare (ignore expecting))
 118   (with-temp-macro-environment (macro-env-dict)
 119     (dolist (macro symbol-macros)
 120       (destructuring-bind (name expansion)
 121           macro
 122         (setf (get-macro-spec name macro-env-dict)
 123               (cons t (make-ps-macro-function () (list `',expansion))))))
 124     (compile-parenscript-form `(progn ,@body))))
 125
 126 (define-ps-special-form defmacro (expecting name args &body body)
 127   (declare (ignore expecting))
 128   (define-script-macro% name args body :symbol-macro-p nil)
 129   nil)
 130
 131 (define-ps-special-form define-symbol-macro (expecting name expansion)
 132   (declare (ignore expecting))
 133   (define-script-macro% name () (list `',expansion) :symbol-macro-p t)
 134   nil)
 135
 136 (defpsmacro lisp (&body forms)
 137   "Evaluates the given forms in Common Lisp at ParenScript
 138 macro-expansion time. The value of the last form is treated as a
 139 ParenScript expression and is inserted into the generated Javascript
 140 \(use nil for no-op)."
 141   (eval (cons 'progn forms)))
 142
 143 (defpsmacro rebind (variables &body body)
 144   "Creates a new js lexical environment and copies the given
 145 variable(s) there. Executes the body in the new environment. This
 146 has the same effect as a new (let () ...) form in lisp but works on
 147 the js side for js closures."
 148   (unless (listp variables)
 149     (setf variables (list variables)))
 150   `((lambda ()
 151       (let ((new-context (new *object)))
 152         ,@(loop for variable in variables
 153                 collect `(setf (slot-value new-context ,(symbol-to-js variable))
 154                                ,variable))
 155         (with new-context
 156           ,@body)))))
 157
 158 (eval-when (:compile-toplevel :load-toplevel :execute)
 159   (defun parse-function-body (body)
 160     ;; (format t "parsing function body ~A~%" body)
 161     (let* ((documentation
 162             (when (stringp (first body))
 163               (first body)))
 164            (body-forms (if documentation (rest body) body)))
 165       (values
 166        body-forms
 167        documentation)))
 168
 169   (defun parse-key-spec (key-spec)
 170     "parses an &key parameter.  Returns 4 values:
 171 var, init-form,  keyword-name, supplied-p-var, init-form-supplied-p.
 172
 173 Syntax of key spec:
 174 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
 175 "
 176     (let* ((var (cond ((symbolp key-spec) key-spec)
 177                       ((and (listp key-spec) (symbolp (first key-spec))) (first key-spec))
 178                       ((and (listp key-spec) (listp (first key-spec)))   (second key-spec))))
 179            (keyword-name (if (and (listp key-spec) (listp (first key-spec)))
 180                              (first (first key-spec))
 181                              (intern (string var) :keyword)))
 182            (init-form (if (listp key-spec) (second key-spec) nil))
 183            (init-form-supplied-p (if (listp key-spec) t nil))
 184            (supplied-p-var (if (listp key-spec) (third key-spec) nil)))
 185       (values var init-form keyword-name supplied-p-var init-form-supplied-p)))
 186
 187   (defun parse-optional-spec (spec)
 188     "Parses an &optional parameter.  Returns 3 values: var, init-form, supplied-p-var.
 189 [&optional {var | (var [init-form [supplied-p-parameter]])}*] "
 190     (let* ((var (cond ((symbolp spec) spec)
 191                       ((and (listp spec) (first spec)))))
 192            (init-form (if (listp spec) (second spec)))
 193            (supplied-p-var (if (listp spec) (third spec))))
 194       (values var init-form supplied-p-var)))
 195
 196   (defun parse-aux-spec (spec)
 197     "Returns two values: variable and init-form"
 198 ;; [&aux {var | (var [init-form])}*])
 199     (values (if (symbolp spec) spec (first spec))
 200             (when (listp spec) (second spec))))
 201
 202   (defun parse-extended-function (lambda-list body &optional name)
 203     "Returns two values: the effective arguments and body for a function with
 204 the given lambda-list and body."
 205
 206 ;; The lambda list is transformed as follows, since a javascript lambda list is just a
 207 ;; list of variable names, and you have access to the arguments variable inside the function:
 208 ;; * standard variables are the mapped directly into the js-lambda list
 209 ;; * optional variables' variable names are mapped directly into the lambda list,
 210 ;;   and for each optional variable with name v and default value d, a form is produced
 211 ;;   (defaultf v d)
 212 ;; * when any keyword variables are in the lambda list, a single 'optional-args' variable is
 213 ;;   appended to the js-lambda list as the last argument.  WITH-SLOTS is used for all
 214 ;;   the variables with  inside the body of the function,
 215     ;;   a (with-slots ((var-name key-name)) optional-args ...)
 216     (declare (ignore name))
 217     (multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? aux
 218                                     more? more-context more-count key-object)
 219         (parse-lambda-list lambda-list)
 220       (declare (ignore allow? aux? aux more? more-context more-count))
 221       (let* ((options-var (or key-object (ps-gensym)))
 222              ;; optionals are of form (var default-value)
 223              (effective-args
 224               (remove-if
 225                #'null
 226                (append requireds
 227                        (mapcar #'parse-optional-spec optionals)
 228                        (when keys (list options-var)))))
 229              ;; an alist of arg -> default val
 230              (initform-pairs
 231               (remove
 232                nil
 233                (append
 234                 ;; optional arguments first
 235                 (mapcar #'(lambda (opt-spec)
 236                             (multiple-value-bind (var val) (parse-optional-spec opt-spec)
 237                               (cons var val)))
 238                         optionals)
 239                 (if keys? (list (cons options-var '(create))))
 240                 (mapcar #'(lambda (key-spec)
 241                             (multiple-value-bind (var val x y specified?) (parse-key-spec key-spec)
 242                               (declare (ignore x y))
 243                               (when specified? (cons var val))))
 244                         keys))))
 245              (body-paren-forms (parse-function-body body)) ;remove documentation
 246              ;;
 247              (initform-forms
 248               (mapcar #'(lambda (default-pair)
 249                           `(defaultf ,(car default-pair) ,(cdr default-pair)))
 250                       initform-pairs))
 251              (rest-form
 252               (if rest?
 253                   (with-ps-gensyms (i)
 254                     `(progn (defvar ,rest array)
 255                             (dotimes (,i (- arguments.length ,(length effective-args)))
 256                               (setf (aref ,rest ,i) (aref arguments (+ ,i ,(length effective-args)))))))
 257                   `(progn)))
 258              (effective-body   (append initform-forms (list rest-form) body-paren-forms))
 259              (effective-body
 260               (if keys?
 261                   (list `(with-slots ,(mapcar #'(lambda (key-spec)
 262                                                   (multiple-value-bind (var x key-name)
 263                                                       (parse-key-spec key-spec)
 264                                                     (declare (ignore x))
 265                                                     (list var key-name)))
 266                                               keys)
 267                           ,options-var
 268                           ,@effective-body))
 269                   effective-body)))
 270         (values effective-args effective-body)))))
 271
 272 (defpsmacro defun (name lambda-list &body body)
 273   "An extended defun macro that allows cool things like keyword arguments.
 274 lambda-list::=
 275  (var*
 276   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 277   [&rest var]
 278   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 279   [&aux {var | (var [init-form])}*])"
 280   (if (symbolp name)
 281       `(defun-normal ,name ,lambda-list ,@body)
 282       (progn (assert (and (= (length name) 2) (eql 'setf (car name))) ()
 283                      "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
 284              `(defun-setf ,name ,lambda-list ,@body))))
 285
 286 (defpsmacro defun-normal (name lambda-list &body body)
 287   (multiple-value-bind (effective-args effective-body)
 288       (parse-extended-function lambda-list body name)
 289     `(%js-defun ,name ,effective-args
 290       ,@effective-body)))
 291
 292 (defvar *defun-setf-name-prefix* "__setf_")
 293
 294 (defpsmacro defun-setf (setf-name lambda-list &body body)
 295   (let ((mangled-function-name (intern (concatenate 'string *defun-setf-name-prefix* (symbol-name (second setf-name)))
 296                                        (symbol-package (second setf-name))))
 297         (function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords))))
 298     `(progn (defsetf ,(second setf-name) ,(cdr lambda-list) (store-var)
 299               `(,',mangled-function-name ,store-var ,@(list ,@function-args)))
 300             (defun ,mangled-function-name ,lambda-list ,@body))))
 301
 302 (defpsmacro lambda (lambda-list &body body)
 303   "An extended defun macro that allows cool things like keyword arguments.
 304 lambda-list::=
 305  (var*
 306   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 307   [&rest var]
 308   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 309   [&aux {var | (var [init-form])}*])"
 310   (multiple-value-bind (effective-args effective-body)
 311       (parse-extended-function lambda-list body)
 312     `(%js-lambda ,effective-args
 313       ,@effective-body)))
 314
 315 (defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
 316   (setf (get-macro-spec access-fn *script-setf-expanders*)
 317         (compile nil
 318                  (let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords)))
 319                    `(lambda (access-fn-args store-form)
 320                      (destructuring-bind ,lambda-list
 321                                access-fn-args
 322                        (let* ((,store-var (ps-gensym))
 323                               (gensymed-names (loop repeat ,(length var-bindings) collecting (ps-gensym)))
 324                               (gensymed-arg-bindings (mapcar #'list gensymed-names (list ,@var-bindings))))
 325                          (destructuring-bind ,var-bindings
 326                              gensymed-names
 327                            `(let (,@gensymed-arg-bindings
 328                                   (,,store-var ,store-form))
 329                              ,,form))))))))
 330   nil)
 331
 332 (defpsmacro defsetf-short (access-fn update-fn &optional docstring)
 333   (declare (ignore docstring))
 334   (setf (get-macro-spec access-fn *script-setf-expanders*)
 335         (lambda (access-fn-args store-form)
 336           `(,update-fn ,@access-fn-args ,store-form)))
 337   nil)
 338
 339 (defpsmacro defsetf (access-fn &rest args)
 340   `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
 341
 342 (defpsmacro setf (&rest args)
 343   (flet ((process-setf-clause (place value-form)
 344            (if (and (listp place) (get-macro-spec (car place) *script-setf-expanders*))
 345                (funcall (get-macro-spec (car place) *script-setf-expanders*) (cdr place) value-form)
 346                (let ((exp-place (ps-macroexpand place)))
 347                  (if (and (listp exp-place) (get-macro-spec (car exp-place) *script-setf-expanders*))
 348                      (funcall (get-macro-spec (car exp-place) *script-setf-expanders*) (cdr exp-place) value-form)
 349                      `(setf1% ,exp-place ,value-form))))))
 350     (assert (evenp (length args)) ()
 351             "~s does not have an even number of arguments." (cons 'setf args))
 352     `(progn ,@(loop for (place value) on args by #'cddr collect (process-setf-clause place value)))))