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