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     string= eql
  13     eq      eql
  14     =       eql
  15     list    array
  16     elt     aref))
  17
  18 (defpsmacro null (x)
  19   `(equal ,x nil))
  20
  21 ;;; Math
  22
  23 (defmacro def-js-maths (&rest mathdefs)
  24   `(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def)) mathdefs)))
  25
  26 (def-js-maths
  27     (max (&rest nums) `((@ *math max) ,@nums))
  28     (min (&rest nums) `((@ *math min) ,@nums))
  29     (floor (n &optional divisor) `((@ *math floor) ,(if divisor `(/ ,n ,divisor) n)))
  30     (ceiling (n &optional divisor) `((@ *math ceil) ,(if divisor `(/ ,n ,divisor) n)))
  31     (round (n &optional divisor) `((@ *math round) ,(if divisor `(/ ,n ,divisor) n)))
  32     (sin (n) `((@ *math sin) ,n))
  33     (cos (n) `((@ *math cos) ,n))
  34     (tan (n) `((@ *math tan) ,n))
  35     (asin (n) `((@ *math asin) ,n))
  36     (acos (n) `((@ *math acos) ,n))
  37     (atan (y &optional x) (if x `((@ *math atan2) ,y ,x) `((@ *math atan) ,y)))
  38     (sinh (n) `((lambda (x) (return (/ (- (exp x) (exp (- x))) 2))) ,n))
  39     (cosh (n) `((lambda (x) (return (/ (+ (exp x) (exp (- x))) 2))) ,n))
  40     (tanh (n) `((lambda (x) (return (/ (- (exp x) (exp (- x))) (+ (exp x) (exp (- x)))))) ,n))
  41     (asinh (n) `((lambda (x) (return (log (+ x (sqrt (1+ (* x x))))))) ,n))
  42     (acosh (n) `((lambda (x) (return (* 2 (log (+ (sqrt (/ (1+ x) 2)) (sqrt (/ (1- x) 2))))))) ,n))
  43     (atanh (n) `((lambda (x) (return (/ (- (log (+ 1 x)) (log (- 1 x))) 2))) ,n))
  44     (1+ (n) `(+ ,n 1))
  45     (1- (n) `(- ,n 1))
  46     (abs (n) `((@ *math abs) ,n))
  47     (evenp (n) `(not (oddp ,n)))
  48     (oddp (n) `(% ,n 2))
  49     (exp (n) `((@ *math exp) ,n))
  50     (expt (base power) `((@ *math pow) ,base ,power))
  51     (log (n &optional base)
  52       (or (and (null base) `((@ *math log) ,n))
  53           (and (numberp base) (= base 10) `(* (log ,n) (@ *math *log10e*)))
  54           `(/ (log ,n) (log ,base))))
  55     (sqrt (n) `((@ *math sqrt) ,n))
  56     (random (&optional upto) (if upto
  57                                  `(floor (* ,upto (random)))
  58                                  '(funcall (@ *math random)))))
  59
  60 (define-ps-symbol-macro pi (getprop *math '*pi*))
  61
  62 ;;; Types
  63
  64 (defpsmacro stringp (x)
  65   `(string= (typeof ,x) "string"))
  66
  67 (defpsmacro numberp (x)
  68   `(string= (typeof ,x) "number"))
  69
  70 (defpsmacro functionp (x)
  71   `(string= (typeof ,x) "function"))
  72
  73 (defpsmacro objectp (x)
  74   `(string= (typeof ,x) "object"))
  75
  76 (defpsmacro undefined (x)
  77   `(eql undefined ,x))
  78
  79 (defpsmacro defined (x)
  80   `(not (undefined ,x)))
  81
  82 ;;; Data structures
  83
  84 (defpsmacro [] (&rest args)
  85   `(array ,@(mapcar (lambda (arg)
  86                       (if (and (consp arg) (not (equal '[] (car arg))))
  87                           (cons '[] arg)
  88                           arg))
  89                     args)))
  90
  91 (defpsmacro make-array (&rest initial-values)
  92   `(new (*array ,@initial-values)))
  93
  94 (defpsmacro length (a)
  95   `(getprop ,a 'length))
  96
  97 ;;; Getters
  98
  99 (defpsmacro getprop (obj &rest slots)
 100   (if (null (rest slots))
 101       `(%js-getprop ,obj ,(first slots))
 102       `(getprop (getprop ,obj ,(first slots)) ,@(rest slots))))
 103
 104 (defpsmacro @ (obj &rest props)
 105   "Handy getprop/aref composition macro."
 106   (if props
 107       `(@ (getprop ,obj ,(if (symbolp (car props))
 108                              `',(car props)
 109                              (car props)))
 110           ,@(cdr props))
 111       obj))
 112
 113 (defpsmacro chain (&rest method-calls)
 114   (labels ((do-chain (method-calls)
 115              (if (cdr method-calls)
 116                  (if (listp (car method-calls))
 117                      `((@ ,(do-chain (cdr method-calls)) ,(caar method-calls)) ,@(cdar method-calls))
 118                      `(@ ,(do-chain (cdr method-calls)) ,(car method-calls)))
 119                  (car method-calls))))
 120     (do-chain (reverse method-calls))))
 121
 122 (defpsmacro with-slots (slots object &rest body)
 123   (flet ((slot-var (slot)
 124            (if (listp slot)
 125                (first slot)
 126                slot))
 127          (slot-symbol (slot)
 128            (if (listp slot)
 129                (second slot)
 130                slot)))
 131     `(symbol-macrolet ,(mapcar (lambda (slot)
 132                                  `(,(slot-var slot) (getprop ,object ',(slot-symbol slot))))
 133                                slots)
 134        ,@body)))
 135
 136 ;;; multiple values
 137
 138 (defpsmacro values (&optional main &rest additional)
 139   (when main
 140     (if additional
 141         (with-ps-gensyms (val1 valrest)
 142           `(let ((,val1 ,main)
 143                  (,valrest (list ,@additional)))
 144              (when (defined (@ arguments :callee :caller :mv))
 145                (setf (@ arguments :callee :caller :mv) ,valrest))
 146              ,val1))
 147         main)))
 148
 149 (defpsmacro multiple-value-bind (vars expr &body body)
 150   (let ((expr (ps-macroexpand expr)))
 151     (if (and (consp expr) (implicit-progn-form? expr))
 152         `(,@(butlast expr)
 153             (multiple-value-bind ,vars
 154                 ,@(last expr)
 155               ,@body))
 156         (with-ps-gensyms (mv prev-mv)
 157           `(let ((,prev-mv (@ arguments :callee :mv)))
 158              (try
 159               (progn
 160                 (setf (@ arguments :callee :mv) t)
 161                 (let ((,(car vars) ,expr)
 162                       (,mv (if (objectp (@ arguments :callee :mv))
 163                                (@ arguments :callee :mv)
 164                                (make-array ,(1- (length vars))))))
 165                   (destructuring-bind ,(cdr vars) ,mv
 166                     ,@body)))
 167               (:finally (if (undefined ,prev-mv)
 168                             (delete (@ arguments :callee :mv))
 169                             (setf (@ arguments :callee :mv) ,prev-mv)))))))))
 170
 171 ;;; conditionals
 172
 173 (defpsmacro case (value &rest clauses)
 174   (labels ((make-clause (val body more)
 175              (cond ((and (listp val) (not (eq (car val) 'quote)))
 176                     (append (mapcar #'list (butlast val))
 177                             (make-clause (first (last val)) body more)))
 178                    ((member val '(t otherwise))
 179                     (make-clause 'default body more))
 180                    (more `((,val ,@body break)))
 181                    (t `((,val ,@body))))))
 182     `(switch ,value ,@(mapcon (lambda (clause)
 183                                 (make-clause (car (first clause))
 184                                              (cdr (first clause))
 185                                              (rest clause)))
 186                               clauses))))
 187
 188 (defpsmacro when (test &rest body)
 189   `(if ,test
 190        (progn ,@body)))
 191
 192 (defpsmacro unless (test &rest body)
 193   `(when (not ,test)
 194      ,@body))
 195
 196 ;;; function definition
 197
 198 (defpsmacro defun (name lambda-list &body body)
 199   "An extended defun macro that allows cool things like keyword arguments.
 200 lambda-list::=
 201  (var*
 202   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 203   [&rest var]
 204   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 205   [&aux {var | (var [init-form])}*])"
 206   (if (symbolp name)
 207       `(defun-function ,name ,lambda-list ,@body)
 208       (progn (assert (and (listp name) (= (length name) 2) (eq 'setf (car name))) ()
 209                      "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
 210              `(defun-setf ,name ,lambda-list ,@body))))
 211
 212 (defpsmacro defun-function (name lambda-list &body body)
 213   (multiple-value-bind (effective-args effective-body)
 214       (parse-extended-function lambda-list body)
 215     `(%js-defun ,name ,effective-args
 216                 ,@effective-body)))
 217
 218 (defpsmacro lambda (lambda-list &body body)
 219   "An extended defun macro that allows cool things like keyword arguments.
 220 lambda-list::=
 221  (var*
 222   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 223   [&rest var]
 224   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 225   [&aux {var | (var [init-form])}*])"
 226   (multiple-value-bind (effective-args effective-body)
 227       (parse-extended-function lambda-list body)
 228     `(%js-lambda ,effective-args
 229                  ,@effective-body)))
 230
 231 ;;; defining setf expanders
 232
 233 (defvar *defun-setf-name-prefix* "__setf_")
 234
 235 (defpsmacro defun-setf (setf-name lambda-list &body body)
 236   (let ((mangled-function-name
 237          (intern (concatenate 'string *defun-setf-name-prefix*
 238                               (symbol-name (second setf-name)))
 239                  (symbol-package (second setf-name)))))
 240     (setf (gethash (second setf-name) *ps-setf-expanders*)
 241           (compile
 242            nil
 243            (lambda (access-args store-form)
 244              `(,mangled-function-name ,store-form ,@access-args))))
 245     `(defun ,mangled-function-name ,lambda-list ,@body)))
 246
 247 ;;; slightly broken WRT lambda lists
 248 (defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
 249   (setf (gethash access-fn *ps-setf-expanders*)
 250         (compile
 251          nil
 252          (let ((var-bindings (ordered-set-difference lambda-list
 253                                                      lambda-list-keywords)))
 254            `(lambda (access-fn-args store-form)
 255               (destructuring-bind ,lambda-list
 256                   access-fn-args
 257                 (let* ((,store-var (ps-gensym))
 258                        (gensymed-names (loop repeat ,(length var-bindings)
 259                                           collecting (ps-gensym)))
 260                        (gensymed-arg-bindings (mapcar #'list
 261                                                       gensymed-names
 262                                                       (list ,@var-bindings))))
 263                   (destructuring-bind ,var-bindings
 264                       gensymed-names
 265                     `(let* (,@gensymed-arg-bindings
 266                             (,,store-var ,store-form))
 267                        ,,form))))))))
 268   nil)
 269
 270 (defpsmacro defsetf-short (access-fn update-fn &optional docstring)
 271   (declare (ignore docstring))
 272   (setf (gethash access-fn *ps-setf-expanders*)
 273         (lambda (access-fn-args store-form)
 274           `(,update-fn ,@access-fn-args ,store-form)))
 275   nil)
 276
 277 (defpsmacro defsetf (access-fn &rest args)
 278   `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
 279
 280 ;;; setf
 281
 282 (defpsmacro setf (&rest args)
 283   (assert (evenp (length args)) ()
 284           "~s does not have an even number of arguments." `(setf ,args))
 285   `(progn ,@(loop for (place value) on args by #'cddr collect
 286                  (aif (and (listp place)
 287                            (gethash (car place) *ps-setf-expanders*))
 288                       (funcall it (cdr place) value)
 289                       `(ps-assign ,place ,value)))))
 290
 291 (defpsmacro psetf (&rest args)
 292   (let ((places (loop for x in args by #'cddr collect x))
 293         (vals (loop for x in (cdr args) by #'cddr collect x)))
 294     (let ((gensyms (loop repeat (length places) collect (ps-gensym))))
 295       `(let ,(mapcar #'list gensyms vals)
 296          (setf ,@(mapcan #'list places gensyms))))))
 297
 298 (defun check-setq-args (args)
 299   (let ((vars (loop for x in args by #'cddr collect x)))
 300     (let ((non-var (find-if (complement #'symbolp) vars)))
 301       (when non-var
 302         (error 'type-error :datum non-var :expected-type 'symbol)))))
 303
 304 (defpsmacro setq (&rest args)
 305   (check-setq-args args)
 306   `(setf ,@args))
 307
 308 (defpsmacro psetq (&rest args)
 309   (check-setq-args args)
 310   `(psetf ,@args))
 311
 312 ;;; iteration
 313
 314 (defun do-make-let-bindings (decls)
 315   (mapcar (lambda (x)
 316             (if (atom x)
 317                 x
 318                 (if (endp (cdr x))
 319                     (list (car x))
 320                     (subseq x 0 2))))
 321           decls))
 322
 323 (defun do-make-init-vars (decls)
 324   (mapcar (lambda (x)
 325             (if (atom x)
 326                 x
 327                 (first x)))
 328           decls))
 329
 330 (defun do-make-init-vals (decls)
 331   (mapcar (lambda (x)
 332             (if (or (atom x) (endp (cdr x)))
 333                 nil
 334                 (second x)))
 335           decls))
 336
 337 (defun do-make-for-vars/init (decls)
 338   (mapcar (lambda (x)
 339             (if (atom x) x
 340                 (if (endp (cdr x)) x
 341                     (subseq x 0 2))))
 342           decls))
 343
 344 (defun do-make-for-steps (decls)
 345   (mapcar (lambda (x)
 346             `(setf ,(first x) ,(third x)))
 347           (remove-if (lambda (x)
 348                        (or (atom x) (< (length x) 3)))
 349                      decls)))
 350
 351 (defun do-make-iter-psteps (decls)
 352   `(psetq
 353     ,@(mapcan (lambda (x)
 354                 (list (first x) (third x)))
 355               (remove-if (lambda (x)
 356                            (or (atom x) (< (length x) 3)))
 357                          decls))))
 358
 359 (defpsmacro do* (decls (termination &optional (result nil result?)) &body body)
 360   (if result?
 361       `((lambda ()
 362           (for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
 363                ,@body)
 364           (return ,result)))
 365       `(for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
 366             ,@body)))
 367
 368 (defpsmacro do (decls (termination &optional (result nil result?)) &body body)
 369   (if result?
 370       `((lambda ,(do-make-init-vars decls)
 371           (for () ((not ,termination)) ()
 372                ,@body
 373                ,(do-make-iter-psteps decls))
 374           (return ,result))
 375         ,@(do-make-init-vals decls))
 376       `(let ,(do-make-let-bindings decls)
 377          (for () ((not ,termination)) ()
 378               ,@body
 379               ,(do-make-iter-psteps decls)))))
 380
 381 (defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
 382   `(do* ((,var 0 (1+ ,var)))
 383         ((>= ,var ,count) ,@(when result? (list result)))
 384      ,@body))
 385
 386 (defpsmacro dolist ((var array &optional (result nil result?)) &body body)
 387   (let* ((idx (ps-gensym "_js_idx"))
 388          (introduce-array-var? (not (symbolp array)))
 389          (arrvar (if introduce-array-var?
 390                      (ps-gensym "_js_arrvar")
 391                      array)))
 392     `(do* (,var
 393            ,@(when introduce-array-var?
 394                    (list (list arrvar array)))
 395            (,idx 0 (1+ ,idx)))
 396           ((>= ,idx (getprop ,arrvar 'length))
 397            ,@(when result? (list result)))
 398        (setq ,var (aref ,arrvar ,idx))
 399        ,@body)))
 400
 401 ;;; Concatenation
 402
 403 (defpsmacro concatenate (result-type &rest sequences)
 404   (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.")
 405   (cons '+ sequences))
 406
 407 (defmacro concat-string (&rest things)
 408   "Like concatenate but prints all of its arguments."
 409   `(format nil "~@{~A~}" ,@things))
 410
 411 (defpsmacro concat-string (&rest things)
 412   (cons '+ things))
 413
 414 (defpsmacro append (arr1 &rest arrs)
 415   (if arrs
 416       `((@ ,arr1 concat) ,@arrs)
 417       arr1))
 418
 419 ;;; Destructuring bind
 420
 421 (defun destructuring-wrap (arr n bindings body &key setf?)
 422   (labels ((bind-expr (var expr inner-body)
 423              (if setf?
 424                  `(progn (setf ,var ,expr) ,inner-body)
 425                  `(let ((,var ,expr)) ,inner-body)))
 426            (bind-rest (sym)
 427              (bind-expr sym `(when (> (length ,arr) ,n)
 428                                ((@ ,arr slice) ,n))
 429                         body)))
 430     (cond ((null bindings)
 431            body)
 432           ((atom bindings) ;; dotted destructuring list
 433            (bind-rest bindings))
 434           ((eq (car bindings) '&rest)
 435            (if (and (= (length bindings) 2)
 436                     (atom (second bindings)))
 437                (bind-rest (second bindings))
 438                (error "~a is invalid in destructuring list." bindings)))
 439           ((eq (car bindings) '&optional)
 440            (destructuring-wrap arr n (cdr bindings) body :setf? setf?))
 441           (t (let ((var (car bindings))
 442                    (inner-body (destructuring-wrap arr (1+ n) (cdr bindings) body :setf? setf?)))
 443                (cond ((null var) inner-body)
 444                      ((atom var) (bind-expr var `(aref ,arr ,n) inner-body))
 445                      (t `(,(if setf? 'dset 'destructuring-bind)
 446                            ,var (aref ,arr ,n)
 447                            ,inner-body))))))))
 448
 449 (defpsmacro dset (bindings expr &body body)
 450   (let ((arr (if (complex-js-expr? expr) (ps-gensym) expr)))
 451     `(progn
 452        ,@(unless (eq arr expr) `((setf ,arr ,expr)))
 453        ,(destructuring-wrap arr 0 bindings (cons 'progn body) :setf? t))))
 454
 455 (defpsmacro destructuring-bind (bindings expr &body body)
 456   (let* ((arr (if (complex-js-expr? expr) (ps-gensym) expr))
 457          (bound (destructuring-wrap arr 0 bindings (cons 'progn body))))
 458     (if (eq arr expr)
 459         bound
 460         `(let ((,arr ,expr)) ,bound))))
 461
 462 ;;; Control structures
 463
 464 (defpsmacro ignore-errors (&body body)
 465   `(try (progn ,@body) (:catch (e))))
 466
 467 (defpsmacro prog1 (first &rest others)
 468   (with-ps-gensyms (val)
 469     `(let ((,val ,first))
 470        ,@others
 471        ,val)))
 472
 473 (defpsmacro prog2 (first second &rest others)
 474   `(progn ,first (prog1 ,second ,@others)))
 475
 476 (defpsmacro apply (fn &rest args)
 477   (let ((arglist (if (> (length args) 1)
 478                      `(append (list ,@(butlast args)) ,(car (last args)))
 479                      (first args))))
 480     `(funcall (getprop ,fn 'apply) this ,arglist)))
 481
 482 ;;; misc
 483
 484 (defpsmacro defvar (name &optional
 485                          (value (values) value-provided?)
 486                          documentation)
 487   ;; this must be used as a top-level form, otherwise the resulting
 488   ;; behavior will be undefined.
 489   (declare (ignore documentation))
 490   (pushnew name *ps-special-variables*)
 491   `(var ,name ,@(when value-provided? (list value))))
 492
 493 (defpsmacro let* (bindings &body body)
 494   (if bindings
 495       `(let (,(car bindings))
 496          (let* ,(cdr bindings)
 497            ,@body))
 498       `(progn ,@body)))
 499
 500 (defpsmacro do-set-timeout ((timeout) &body body)
 501   `(set-timeout (lambda () ,@body) ,timeout))