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