src/macros.lisp

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