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