src/macros.lisp

   1 (in-package "PARENSCRIPT")
   2
   3 (define-ps-symbol-macro f js:f)
   4 (define-ps-symbol-macro false js:f)
   5
   6 (macrolet ((define-trivial-mappings (&rest mappings)
   7              `(progn
   8                 ,@(loop for (macro-name ps-op) on mappings by #'cddr collect
   9                        `(defpsmacro ,macro-name (&rest args)
  10                           (cons ',ps-op args))))))
  11   (define-trivial-mappings
  12     equalp equal
  13     eql    equal
  14     eq     equal
  15     =      equal
  16     list   array
  17     elt    aref))
  18
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20 ;;; multiple values
  21
  22 (defpsmacro values (&optional main &rest additional)
  23   (when main
  24     (if additional
  25         (with-ps-gensyms (val1 valrest)
  26           `(let ((,val1 ,main)
  27                  (,valrest (list ,@additional)))
  28              (when (defined (@ arguments :callee :caller :mv))
  29                (setf (@ arguments :callee :caller :mv) ,valrest))
  30              ,val1))
  31         main)))
  32
  33 (defpsmacro multiple-value-bind (vars expr &body body)
  34   (let ((expr (ps-macroexpand expr)))
  35     (if (and (consp expr) (implicit-progn-form? expr))
  36         `(,@(butlast expr)
  37             (multiple-value-bind ,vars
  38                 ,@(last expr)
  39               ,@body))
  40         (with-ps-gensyms (mv prev-mv)
  41           `(let ((,prev-mv (@ arguments :callee :mv)))
  42              (try
  43               (progn
  44                 (setf (@ arguments :callee :mv) t)
  45                 (let ((,(car vars) ,expr)
  46                       (,mv (if (objectp (@ arguments :callee :mv))
  47                                (@ arguments :callee :mv)
  48                                (make-array ,(1- (length vars))))))
  49                   (destructuring-bind ,(cdr vars) ,mv
  50                     ,@body)))
  51               (:finally (if (undefined ,prev-mv)
  52                             (delete (@ arguments :callee :mv))
  53                             (setf (@ arguments :callee :mv) ,prev-mv)))))))))
  54
  55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  56 ;;; conditionals
  57
  58 (defpsmacro case (value &rest clauses)
  59   (labels ((make-clause (val body more)
  60              (cond ((and (listp val) (not (eq (car val) 'quote)))
  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 (defpsmacro when (test &rest body)
  74   `(if ,test
  75        (progn ,@body)))
  76
  77 (defpsmacro unless (test &rest body)
  78   `(when (not ,test)
  79      ,@body))
  80
  81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82 ;;; function definition
  83
  84 (defpsmacro defun (name lambda-list &body body)
  85   "An extended defun macro that allows cool things like keyword arguments.
  86 lambda-list::=
  87  (var*
  88   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
  89   [&rest var]
  90   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
  91   [&aux {var | (var [init-form])}*])"
  92   (if (symbolp name)
  93       `(defun-function ,name ,lambda-list ,@body)
  94       (progn (assert (and (listp name) (= (length name) 2) (eq 'setf (car name))) ()
  95                      "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
  96              `(defun-setf ,name ,lambda-list ,@body))))
  97
  98 (defpsmacro defun-function (name lambda-list &body body)
  99   (multiple-value-bind (effective-args effective-body)
 100       (parse-extended-function lambda-list body)
 101     `(%js-defun ,name ,effective-args
 102                 ,@effective-body)))
 103
 104 (defpsmacro lambda (lambda-list &body body)
 105   "An extended defun macro that allows cool things like keyword arguments.
 106 lambda-list::=
 107  (var*
 108   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 109   [&rest var]
 110   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 111   [&aux {var | (var [init-form])}*])"
 112   (multiple-value-bind (effective-args effective-body)
 113       (parse-extended-function lambda-list body)
 114     `(%js-lambda ,effective-args
 115                  ,@effective-body)))
 116
 117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 118 ;;; defining setf expanders
 119
 120 (defvar *defun-setf-name-prefix* "__setf_")
 121
 122 (defpsmacro defun-setf (setf-name lambda-list &body body)
 123   (let ((mangled-function-name
 124          (intern (concatenate 'string *defun-setf-name-prefix*
 125                               (symbol-name (second setf-name)))
 126                  (symbol-package (second setf-name)))))
 127     (setf (gethash (second setf-name) *ps-setf-expanders*)
 128           (compile
 129            nil
 130            (lambda (access-args store-form)
 131              `(,mangled-function-name ,store-form ,@access-args))))
 132     `(defun ,mangled-function-name ,lambda-list ,@body)))
 133
 134 ;;; slightly broken WRT lambda lists
 135 (defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
 136   (setf (gethash access-fn *ps-setf-expanders*)
 137         (compile
 138          nil
 139          (let ((var-bindings (ordered-set-difference lambda-list
 140                                                      lambda-list-keywords)))
 141            `(lambda (access-fn-args store-form)
 142               (destructuring-bind ,lambda-list
 143                   access-fn-args
 144                 (let* ((,store-var (ps-gensym))
 145                        (gensymed-names (loop repeat ,(length var-bindings)
 146                                           collecting (ps-gensym)))
 147                        (gensymed-arg-bindings (mapcar #'list
 148                                                       gensymed-names
 149                                                       (list ,@var-bindings))))
 150                   (destructuring-bind ,var-bindings
 151                       gensymed-names
 152                     `(let* (,@gensymed-arg-bindings
 153                             (,,store-var ,store-form))
 154                        ,,form))))))))
 155   nil)
 156
 157 (defpsmacro defsetf-short (access-fn update-fn &optional docstring)
 158   (declare (ignore docstring))
 159   (setf (gethash access-fn *ps-setf-expanders*)
 160         (lambda (access-fn-args store-form)
 161           `(,update-fn ,@access-fn-args ,store-form)))
 162   nil)
 163
 164 (defpsmacro defsetf (access-fn &rest args)
 165   `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
 166
 167 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 168 ;;; setf
 169
 170 (defpsmacro setf (&rest args)
 171   (assert (evenp (length args)) ()
 172           "~s does not have an even number of arguments." `(setf ,args))
 173   `(progn ,@(loop for (place value) on args by #'cddr collect
 174                  (aif (and (listp place)
 175                            (gethash (car place) *ps-setf-expanders*))
 176                       (funcall it (cdr place) value)
 177                       `(ps-assign ,place ,value)))))
 178
 179 (defpsmacro psetf (&rest args)
 180   (let ((places (loop for x in args by #'cddr collect x))
 181         (vals (loop for x in (cdr args) by #'cddr collect x)))
 182     (let ((gensyms (loop repeat (length places) collect (ps-gensym))))
 183       `(let ,(mapcar #'list gensyms vals)
 184          (setf ,@(mapcan #'list places gensyms))))))
 185
 186 (defun check-setq-args (args)
 187   (let ((vars (loop for x in args by #'cddr collect x)))
 188     (let ((non-var (find-if (complement #'symbolp) vars)))
 189       (when non-var
 190         (error 'type-error :datum non-var :expected-type 'symbol)))))
 191
 192 (defpsmacro setq (&rest args)
 193   (check-setq-args args)
 194   `(setf ,@args))
 195
 196 (defpsmacro psetq (&rest args)
 197   (check-setq-args args)
 198   `(psetf ,@args))
 199
 200 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 201 ;;; iteration
 202
 203 (defpsmacro for (init-forms cond-forms step-forms &body body)
 204   `(labeled-for nil ,init-forms ,cond-forms ,step-forms ,@body))
 205
 206 (defun do-make-let-bindings (decls)
 207   (mapcar (lambda (x)
 208             (if (atom x)
 209                 x
 210                 (if (endp (cdr x))
 211                     (list (car x))
 212                     (subseq x 0 2))))
 213           decls))
 214
 215 (defun do-make-init-vars (decls)
 216   (mapcar (lambda (x)
 217             (if (atom x)
 218                 x
 219                 (first x)))
 220           decls))
 221
 222 (defun do-make-init-vals (decls)
 223   (mapcar (lambda (x)
 224             (if (or (atom x) (endp (cdr x)))
 225                 nil
 226                 (second x)))
 227           decls))
 228
 229 (defun do-make-for-vars/init (decls)
 230   (mapcar (lambda (x)
 231             (if (atom x) x
 232                 (if (endp (cdr x)) x
 233                     (subseq x 0 2))))
 234           decls))
 235
 236 (defun do-make-for-steps (decls)
 237   (mapcar (lambda (x)
 238             `(setf ,(first x) ,(third x)))
 239           (remove-if (lambda (x)
 240                        (or (atom x) (< (length x) 3)))
 241                      decls)))
 242
 243 (defun do-make-iter-psteps (decls)
 244   `(psetq
 245     ,@(mapcan (lambda (x)
 246                 (list (first x) (third x)))
 247               (remove-if (lambda (x)
 248                            (or (atom x) (< (length x) 3)))
 249                          decls))))
 250
 251 (defpsmacro do* (decls (termination &optional (result nil result?)) &body body)
 252   (if result?
 253       `((lambda ()
 254           (for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
 255                ,@body)
 256           (return ,result)))
 257       `(for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
 258             ,@body)))
 259
 260 (defpsmacro do (decls (termination &optional (result nil result?)) &body body)
 261   (if result?
 262       `((lambda ,(do-make-init-vars decls)
 263           (for () ((not ,termination)) ()
 264                ,@body
 265                ,(do-make-iter-psteps decls))
 266           (return ,result))
 267         ,@(do-make-init-vals decls))
 268       `(let ,(do-make-let-bindings decls)
 269          (for () ((not ,termination)) ()
 270               ,@body
 271               ,(do-make-iter-psteps decls)))))
 272
 273 (defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
 274   `(do* ((,var 0 (1+ ,var)))
 275         ((>= ,var ,count) ,@(when result? (list result)))
 276      ,@body))
 277
 278 (defpsmacro dolist ((var array &optional (result nil result?)) &body body)
 279   (let* ((idx (ps-gensym "_js_idx"))
 280          (introduce-array-var? (not (symbolp array)))
 281          (arrvar (if introduce-array-var?
 282                      (ps-gensym "_js_arrvar")
 283                      array)))
 284     `(do* (,var
 285            ,@(when introduce-array-var?
 286                    (list (list arrvar array)))
 287            (,idx 0 (1+ ,idx)))
 288           ((>= ,idx (getprop ,arrvar 'length))
 289            ,@(when result? (list result)))
 290        (setq ,var (aref ,arrvar ,idx))
 291        ,@body)))
 292
 293 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 294 ;;; misc
 295
 296 (defpsmacro make-array (&rest initial-values)
 297   `(new (*array ,@initial-values)))
 298
 299 (defpsmacro funcall (&rest arg-form)
 300   arg-form)
 301
 302 (defpsmacro defvar (name &optional
 303                          (value (values) value-provided?)
 304                          documentation)
 305   ;; this must be used as a top-level form, otherwise the resulting
 306   ;; behavior will be undefined.
 307   (declare (ignore documentation))
 308   (pushnew name *ps-special-variables*)
 309   `(var ,name ,@(when value-provided? (list value))))
 310
 311 (defpsmacro let* (bindings &body body)
 312   (if bindings
 313       `(let (,(car bindings))
 314          (let* ,(cdr bindings)
 315            ,@body))
 316       `(progn ,@body)))
 317
 318 (defpsmacro getprop (obj &rest slots)
 319   (if (null (rest slots))
 320       `(%js-getprop ,obj ,(first slots))
 321       `(getprop (getprop ,obj ,(first slots)) ,@(rest slots))))
 322
 323 (defpsmacro with-slots (slots object &rest body)
 324   (flet ((slot-var (slot)
 325            (if (listp slot)
 326                (first slot)
 327                slot))
 328          (slot-symbol (slot)
 329            (if (listp slot)
 330                (second slot)
 331                slot)))
 332     `(symbol-macrolet ,(mapcar (lambda (slot)
 333                                  `(,(slot-var slot) (getprop ,object ',(slot-symbol slot))))
 334                                slots)
 335        ,@body)))