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