src/macros.lisp

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