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) `(rem ,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   (expressionize expr
 151     (lambda (expr)
 152       (with-ps-gensyms (mv prev-mv)
 153         `(let ((,prev-mv (@ arguments :callee :mv)))
 154            (try
 155             (progn
 156               (setf (@ arguments :callee :mv) t)
 157               (let ((,(car vars) ,expr)
 158                     (,mv (if (objectp (@ arguments :callee :mv))
 159                              (@ arguments :callee :mv)
 160                              (make-array ,(1- (length vars))))))
 161                 (destructuring-bind ,(cdr vars) ,mv
 162                   ,@body)))
 163             (:finally (if (undefined ,prev-mv)
 164                           (delete (@ arguments :callee :mv))
 165                           (setf (@ arguments :callee :mv) ,prev-mv)))))))))
 166
 167 ;;; conditionals
 168
 169 (defpsmacro case (value &rest clauses)
 170   (labels ((make-clause (val body more)
 171              (cond ((and (listp val) (not (eq (car val) 'quote)))
 172                     (append (mapcar #'list (butlast val))
 173                             (make-clause (first (last val)) body more)))
 174                    ((member val '(t otherwise))
 175                     (make-clause 'default body more))
 176                    (more `((,val ,@body break)))
 177                    (t `((,val ,@body))))))
 178     `(switch ,value ,@(mapcon (lambda (clause)
 179                                 (make-clause (car (first clause))
 180                                              (cdr (first clause))
 181                                              (rest clause)))
 182                               clauses))))
 183
 184 (defpsmacro when (test &rest body)
 185   `(if ,test
 186        (progn ,@body)))
 187
 188 (defpsmacro unless (test &rest body)
 189   `(when (not ,test)
 190      ,@body))
 191
 192 ;;; function definition
 193
 194 (defpsmacro defun (name lambda-list &body body)
 195   "An extended defun macro that allows cool things like keyword arguments.
 196 lambda-list::=
 197  (var*
 198   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 199   [&rest var]
 200   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 201   [&aux {var | (var [init-form])}*])"
 202   (if (symbolp name)
 203       `(defun-function ,name ,lambda-list ,@body)
 204       (progn (assert (and (listp name) (= (length name) 2) (eq 'setf (car name))) ()
 205                      "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
 206              `(defun-setf ,name ,lambda-list ,@body))))
 207
 208 (defpsmacro defun-function (name lambda-list &body body)
 209   (multiple-value-bind (effective-args effective-body)
 210       (parse-extended-function lambda-list body)
 211     `(%js-defun ,name ,effective-args
 212                 ,@effective-body)))
 213
 214 (defpsmacro lambda (lambda-list &body body)
 215   "An extended defun macro that allows cool things like keyword arguments.
 216 lambda-list::=
 217  (var*
 218   [&optional {var | (var [init-form [supplied-p-parameter]])}*]
 219   [&rest var]
 220   [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
 221   [&aux {var | (var [init-form])}*])"
 222   (multiple-value-bind (effective-args effective-body)
 223       (parse-extended-function lambda-list body)
 224     `(%js-lambda ,effective-args
 225                  ,@effective-body)))
 226
 227 ;;; defining setf expanders
 228
 229 (defvar *defun-setf-name-prefix* "__setf_")
 230
 231 (defpsmacro defun-setf (setf-name lambda-list &body body)
 232   (let ((mangled-function-name
 233          (intern (concatenate 'string *defun-setf-name-prefix*
 234                               (symbol-name (second setf-name)))
 235                  (symbol-package (second setf-name)))))
 236     (setf (gethash (second setf-name) *ps-setf-expanders*)
 237           (compile
 238            nil
 239            (lambda (access-args store-form)
 240              `(,mangled-function-name ,store-form ,@access-args))))
 241     `(defun ,mangled-function-name ,lambda-list ,@body)))
 242
 243 ;;; slightly broken WRT lambda lists
 244 (defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
 245   (setf (gethash access-fn *ps-setf-expanders*)
 246         (compile
 247          nil
 248          (let ((var-bindings (ordered-set-difference lambda-list
 249                                                      lambda-list-keywords)))
 250            `(lambda (access-fn-args store-form)
 251               (destructuring-bind ,lambda-list
 252                   access-fn-args
 253                 (let* ((,store-var (ps-gensym))
 254                        (gensymed-names (loop repeat ,(length var-bindings)
 255                                           collecting (ps-gensym)))
 256                        (gensymed-arg-bindings (mapcar #'list
 257                                                       gensymed-names
 258                                                       (list ,@var-bindings))))
 259                   (destructuring-bind ,var-bindings
 260                       gensymed-names
 261                     `(let* (,@gensymed-arg-bindings
 262                             (,,store-var ,store-form))
 263                        ,,form))))))))
 264   nil)
 265
 266 (defpsmacro defsetf-short (access-fn update-fn &optional docstring)
 267   (declare (ignore docstring))
 268   (setf (gethash access-fn *ps-setf-expanders*)
 269         (lambda (access-fn-args store-form)
 270           `(,update-fn ,@access-fn-args ,store-form)))
 271   nil)
 272
 273 (defpsmacro defsetf (access-fn &rest args)
 274   `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
 275
 276 ;;; setf
 277
 278 (defpsmacro setf (&rest args)
 279   (assert (evenp (length args)) ()
 280           "~s does not have an even number of arguments." `(setf ,args))
 281   `(progn ,@(loop for (place value) on args by #'cddr collect
 282                  (aif (and (listp place)
 283                            (gethash (car place) *ps-setf-expanders*))
 284                       (funcall it (cdr place) value)
 285                       `(ps-assign ,place ,value)))))
 286
 287 (defpsmacro psetf (&rest args)
 288   (let ((places (loop for x in args by #'cddr collect x))
 289         (vals (loop for x in (cdr args) by #'cddr collect x)))
 290     (let ((gensyms (loop repeat (length places) collect (ps-gensym))))
 291       `(let ,(mapcar #'list gensyms vals)
 292          (setf ,@(mapcan #'list places gensyms))))))
 293
 294 (defun check-setq-args (args)
 295   (let ((vars (loop for x in args by #'cddr collect x)))
 296     (let ((non-var (find-if (complement #'symbolp) vars)))
 297       (when non-var
 298         (error 'type-error :datum non-var :expected-type 'symbol)))))
 299
 300 (defpsmacro setq (&rest args)
 301   (check-setq-args args)
 302   `(setf ,@args))
 303
 304 (defpsmacro psetq (&rest args)
 305   (check-setq-args args)
 306   `(psetf ,@args))
 307
 308 ;;; iteration
 309
 310 (defun do-make-let-bindings (decls)
 311   (mapcar (lambda (x)
 312             (if (atom x)
 313                 x
 314                 (if (endp (cdr x))
 315                     (list (car x))
 316                     (subseq x 0 2))))
 317           decls))
 318
 319 (defun do-make-init-vars (decls)
 320   (mapcar (lambda (x)
 321             (if (atom x)
 322                 x
 323                 (first x)))
 324           decls))
 325
 326 (defun do-make-init-vals (decls)
 327   (mapcar (lambda (x)
 328             (if (or (atom x) (endp (cdr x)))
 329                 nil
 330                 (second x)))
 331           decls))
 332
 333 (defun do-make-for-vars/init (decls)
 334   (mapcar (lambda (x)
 335             (if (atom x) x
 336                 (if (endp (cdr x)) x
 337                     (subseq x 0 2))))
 338           decls))
 339
 340 (defun do-make-for-steps (decls)
 341   (mapcar (lambda (x)
 342             `(setf ,(first x) ,(third x)))
 343           (remove-if (lambda (x)
 344                        (or (atom x) (< (length x) 3)))
 345                      decls)))
 346
 347 (defun do-make-iter-psteps (decls)
 348   `(psetq
 349     ,@(mapcan (lambda (x)
 350                 (list (first x) (third x)))
 351               (remove-if (lambda (x)
 352                            (or (atom x) (< (length x) 3)))
 353                          decls))))
 354
 355 (defpsmacro do* (decls (termination &optional (result nil result?)) &body body)
 356   (if result?
 357       `((lambda ()
 358           (for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
 359                ,@body)
 360           (return ,result)))
 361       `(for ,(do-make-for-vars/init decls) ((not ,termination)) ,(do-make-for-steps decls)
 362             ,@body)))
 363
 364 (defpsmacro do (decls (termination &optional (result nil result?)) &body body)
 365   (if result?
 366       `((lambda ,(do-make-init-vars decls)
 367           (for () ((not ,termination)) ()
 368                ,@body
 369                ,(do-make-iter-psteps decls))
 370           (return ,result))
 371         ,@(do-make-init-vals decls))
 372       `(let ,(do-make-let-bindings decls)
 373          (for () ((not ,termination)) ()
 374               ,@body
 375               ,(do-make-iter-psteps decls)))))
 376
 377 (defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
 378   `(do* ((,var 0 (1+ ,var)))
 379         ((>= ,var ,count) ,@(when result? (list result)))
 380      ,@body))
 381
 382 (defpsmacro dolist ((var array &optional (result nil result?)) &body body)
 383   (let* ((idx (ps-gensym "_js_idx"))
 384          (introduce-array-var? (not (symbolp array)))
 385          (arrvar (if introduce-array-var?
 386                      (ps-gensym "_js_arrvar")
 387                      array)))
 388     `(do* (,var
 389            ,@(when introduce-array-var?
 390                    (list (list arrvar array)))
 391            (,idx 0 (1+ ,idx)))
 392           ((>= ,idx (getprop ,arrvar 'length))
 393            ,@(when result? (list result)))
 394        (setq ,var (aref ,arrvar ,idx))
 395        ,@body)))
 396
 397 ;;; Concatenation
 398
 399 (defpsmacro concatenate (result-type &rest sequences)
 400   (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.")
 401   (cons '+ sequences))
 402
 403 (defun str (&rest things)
 404   "Like concatenate but prints all of its arguments."
 405   (format nil "~{~A~}" things))
 406
 407 (defpsmacro str (&rest things)
 408   (if (and (= (length things) 1) (stringp (car things)))
 409       (car things)
 410       `((@ (list ,@things) :join) "")))
 411
 412 (defpsmacro append (arr1 &rest arrs)
 413   (if arrs
 414       `((@ ,arr1 concat) ,@arrs)
 415       arr1))
 416
 417 ;;; Destructuring bind
 418
 419 (defun destructuring-wrap (arr n bindings body &key setf?)
 420   (labels ((bind-expr (var expr inner-body)
 421              (if setf?
 422                  `(progn (setf ,var ,expr) ,inner-body)
 423                  `(let ((,var ,expr)) ,inner-body)))
 424            (bind-rest (sym)
 425              (bind-expr sym `(if (> (length ,arr) ,n)
 426                                  ((@ ,arr slice) ,n)
 427                                  '())
 428                         body)))
 429     (cond ((null bindings)
 430            body)
 431           ((atom bindings) ;; dotted destructuring list
 432            (bind-rest bindings))
 433           ((eq (car bindings) '&rest)
 434            (if (and (= (length bindings) 2)
 435                     (atom (second bindings)))
 436                (bind-rest (second bindings))
 437                (error "~a is invalid in destructuring list." bindings)))
 438           ((eq (car bindings) '&optional)
 439            (destructuring-wrap arr n (cdr bindings) body :setf? setf?))
 440           (t (let ((var (car bindings))
 441                    (inner-body (destructuring-wrap arr (1+ n) (cdr bindings) body :setf? setf?)))
 442                (cond ((null var) inner-body)
 443                      ((atom var) (bind-expr var `(aref ,arr ,n) inner-body))
 444                      (t `(,(if setf? 'dset 'destructuring-bind)
 445                            ,var (aref ,arr ,n)
 446                            ,inner-body))))))))
 447
 448 (defpsmacro dset (bindings expr &body body)
 449   (let ((arr (if (complex-js-expr? expr) (ps-gensym) expr)))
 450     `(progn
 451        ,@(unless (eq arr expr) `((setf ,arr ,expr)))
 452        ,(destructuring-wrap arr 0 bindings (cons 'progn body) :setf? t))))
 453
 454 (defpsmacro destructuring-bind (bindings expr &body body)
 455   (let* ((arr (if (complex-js-expr? expr) (ps-gensym) expr))
 456          (bound (destructuring-wrap arr 0 bindings (cons 'progn body))))
 457     (if (eq arr expr)
 458         bound
 459         `(let ((,arr ,expr)) ,bound))))
 460
 461 ;;; Control structures
 462
 463 (defpsmacro return (&optional form)
 464   (expressionize form (lambda (x) `(return-exp ,x))))
 465
 466 (defpsmacro ignore-errors (&body body)
 467   `(try (progn ,@body) (:catch (e))))
 468
 469 (defpsmacro prog1 (first &rest others)
 470   (with-ps-gensyms (val)
 471     `(let ((,val ,first))
 472        ,@others
 473        ,val)))
 474
 475 (defpsmacro prog2 (first second &rest others)
 476   `(progn ,first (prog1 ,second ,@others)))
 477
 478 (defpsmacro apply (fn &rest args)
 479   (let ((arglist (if (> (length args) 1)
 480                      `(append (list ,@(butlast args)) ,(car (last args)))
 481                      (first args))))
 482     `(funcall (getprop ,fn 'apply) this ,arglist)))
 483
 484 ;;; misc
 485
 486 (defpsmacro defvar (name &optional
 487                          (value (values) value-provided?)
 488                          documentation)
 489   ;; this must be used as a top-level form, otherwise the resulting
 490   ;; behavior will be undefined.
 491   (declare (ignore documentation))
 492   (pushnew name *ps-special-variables*)
 493   `(var ,name ,@(when value-provided? (list value))))
 494
 495 (defpsmacro let* (bindings &body body)
 496   (if bindings
 497       `(let (,(car bindings))
 498          (let* ,(cdr bindings)
 499            ,@body))
 500       `(progn ,@body)))