src/lib/ps-macro-lib.lisp

   1 (in-package "PARENSCRIPT")
   2
   3 ;;; Handy utilities for doing common tasks found in many web browser
   4 ;;; JavaScript implementations
   5
   6 (defpsmacro do-set-timeout ((timeout) &body body)
   7   `(set-timeout (lambda () ,@body) ,timeout))
   8
   9 ;;; Arithmetic
  10
  11 (defmacro def-js-maths (&rest mathdefs)
  12   `(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def)) mathdefs)))
  13
  14 (def-js-maths
  15     (max (&rest nums) `((@ *math max) ,@nums))
  16     (min (&rest nums) `((@ *math min) ,@nums))
  17     (floor (n &optional divisor) `((@ *math floor) ,(if divisor `(/ ,n ,divisor) n)))
  18     (ceiling (n &optional divisor) `((@ *math ceil) ,(if divisor `(/ ,n ,divisor) n)))
  19     (round (n &optional divisor) `((@ *math round) ,(if divisor `(/ ,n ,divisor) n)))
  20     (sin (n) `((@ *math sin) ,n))
  21     (cos (n) `((@ *math cos) ,n))
  22     (tan (n) `((@ *math tan) ,n))
  23     (asin (n) `((@ *math asin) ,n))
  24     (acos (n) `((@ *math acos) ,n))
  25     (atan (y &optional x) (if x `((@ *math atan2) ,y ,x) `((@ *math atan) ,y)))
  26     (sinh (n) `((lambda (x) (return (/ (- (exp x) (exp (- x))) 2))) ,n))
  27     (cosh (n) `((lambda (x) (return (/ (+ (exp x) (exp (- x))) 2))) ,n))
  28     (tanh (n) `((lambda (x) (return (/ (- (exp x) (exp (- x))) (+ (exp x) (exp (- x)))))) ,n))
  29     (asinh (n) `((lambda (x) (return (log (+ x (sqrt (1+ (* x x))))))) ,n))
  30     (acosh (n) `((lambda (x) (return (* 2 (log (+ (sqrt (/ (1+ x) 2)) (sqrt (/ (1- x) 2))))))) ,n))
  31     (atanh (n) `((lambda (x) (return (/ (- (log (+ 1 x)) (log (- 1 x))) 2))) ,n))
  32     (1+ (n) `(+ ,n 1))
  33     (1- (n) `(- ,n 1))
  34     (abs (n) `((@ *math abs) ,n))
  35     (evenp (n) `(not (oddp ,n)))
  36     (oddp (n) `(% ,n 2))
  37     (exp (n) `((@ *math exp) ,n))
  38     (expt (base power) `((@ *math pow) ,base ,power))
  39     (log (n &optional base)
  40       (or (and (null base) `((@ *math log) ,n))
  41           (and (numberp base) (= base 10) `(* (log ,n) (@ *math *log10e*)))
  42           `(/ (log ,n) (log ,base))))
  43     (sqrt (n) `((@ *math sqrt) ,n))
  44     (random (&optional upto) (if upto
  45                                  `(floor (* ,upto ((@ *math random))))
  46                                  '((@ *math random)))))
  47
  48 (define-ps-symbol-macro pi (@ *math *pi*))
  49
  50 ;;; Exception handling
  51
  52 (defpsmacro ignore-errors (&body body)
  53   `(try (progn ,@body) (:catch (e))))
  54
  55 ;;; Data structures
  56
  57 (defpsmacro [] (&rest args)
  58   `(array ,@(mapcar (lambda (arg)
  59                       (if (and (consp arg) (not (equal '[] (car arg))))
  60                           (cons '[] arg)
  61                           arg))
  62                     args)))
  63
  64 (defpsmacro length (a)
  65   `(@ ,a length))
  66
  67 ;;; Misc
  68
  69 (defpsmacro null (x)
  70   `(= ,x nil))
  71
  72 (defpsmacro undefined (x)
  73   `(=== undefined ,x))
  74
  75 (defpsmacro defined (x)
  76   `(not (undefined ,x)))
  77
  78 (defpsmacro @ (obj &rest props)
  79   "Handy slot-value/aref composition macro."
  80   (if props
  81       `(@ (slot-value ,obj ,(if (symbolp (car props)) `',(car props) (car props))) ,@(cdr props))
  82       obj))
  83
  84 (defpsmacro chain (&rest method-calls)
  85   (labels ((do-chain (method-calls)
  86              (if (cdr method-calls)
  87                  (if (listp (car method-calls))
  88                      `((@ ,(do-chain (cdr method-calls)) ,(caar method-calls)) ,@(cdar method-calls))
  89                      `(@ ,(do-chain (cdr method-calls)) ,(car method-calls)))
  90                  (car method-calls))))
  91     (do-chain (reverse method-calls))))
  92
  93
  94 (defpsmacro concatenate (result-type &rest sequences)
  95   (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.")
  96   (cons '+ sequences))
  97
  98 (defmacro concat-string (&rest things)
  99   "Like concatenate but prints all of its arguments."
 100   `(format nil "~@{~A~}" ,@things))
 101
 102 (defpsmacro concat-string (&rest things)
 103   (cons '+ things))
 104
 105 (defpsmacro elt (array index)
 106   `(aref ,array ,index))
 107
 108 (defpsmacro with-lambda (()  &body body)
 109   "Wraps BODY in a lambda so that it can be treated as an expression."
 110   `((lambda () ,@body)))
 111
 112 (defpsmacro stringp (x)
 113   `(= (typeof ,x) "string"))
 114
 115 (defpsmacro numberp (x)
 116   `(= (typeof ,x) "number"))
 117
 118 (defpsmacro functionp (x)
 119   `(= (typeof ,x) "function"))
 120
 121 (defpsmacro objectp (x)
 122   `(= (typeof ,x) "object"))
 123
 124 (defpsmacro memoize (fn-expr)
 125   (destructuring-bind (defun fn-name (arg) &rest fn-body)
 126       fn-expr
 127     (declare (ignore defun))
 128     (with-ps-gensyms (table value compute-fn)
 129       `(let ((,table {}))
 130          (defun ,compute-fn (,arg) ,@fn-body)
 131          (defun ,fn-name (,arg)
 132            (let ((,value (aref ,table ,arg)))
 133              (when (null ,value)
 134                (setf ,value (,compute-fn ,arg))
 135                (setf (aref ,table ,arg) ,value))
 136              (return ,value)))))))
 137
 138 (defpsmacro append (arr1 &rest arrs)
 139   (if arrs
 140       `((@ ,arr1 concat) ,@arrs)
 141       arr1))
 142
 143 (defpsmacro apply (fn &rest args)
 144   (let ((arglist (if (> (length args) 1)
 145                      `(append (list ,@(butlast args)) ,(car (last args)))
 146                      (first args))))
 147     `((@ ,fn apply) this ,arglist)))
 148
 149 (defun destructuring-wrap (arr n bindings body &key setf?)
 150   (cond ((null bindings)
 151          body)
 152         ((atom bindings)
 153          ;; dotted destructuring list
 154          `(let ((,bindings (when (> (length ,arr) ,n)
 155                              ((@ ,arr slice) ,n))))
 156             ,body))
 157         (t (let ((var (car bindings))
 158                  (inner-body (destructuring-wrap arr (1+ n) (cdr bindings) body :setf? setf?)))
 159              (cond ((null var) inner-body)
 160                    ((atom var) (if setf?
 161                                    `(progn (setf ,var (aref ,arr ,n))
 162                                            ,inner-body)
 163                                    `(let ((,var (aref ,arr ,n)))
 164                                       ,inner-body)))
 165                    (t `(,(if setf? 'dset 'destructuring-bind)
 166                          ,var (aref ,arr ,n)
 167                          ,inner-body)))))))
 168
 169 (defpsmacro dset (bindings expr &body body)
 170   (let ((arr (if (complex-js-expr? expr) (ps-gensym) expr)))
 171     `(progn
 172        ,@(unless (eq arr expr) `((setf ,arr ,expr)))
 173        ,(destructuring-wrap arr 0 bindings (cons 'progn body) :setf? t))))
 174
 175 (defpsmacro destructuring-bind (bindings expr &body body)
 176   (let* ((arr (if (complex-js-expr? expr) (ps-gensym) expr))
 177          (bound (destructuring-wrap arr 0 bindings (cons 'progn body))))
 178     (if (eq arr expr)
 179         bound
 180         `(let ((,arr ,expr)) ,bound))))