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 concatenate (result-type &rest sequences)
  85   (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.")
  86   (cons '+ sequences))
  87
  88 (defmacro concat-string (&rest things)
  89   "Like concatenate but prints all of its arguments."
  90   `(format nil "~@{~A~}" ,@things))
  91
  92 (defpsmacro concat-string (&rest things)
  93   (cons '+ things))
  94
  95 (defpsmacro elt (array index)
  96   `(aref ,array ,index))
  97
  98 (defpsmacro with-lambda (()  &body body)
  99   "Wraps BODY in a lambda so that it can be treated as an expression."
 100   `((lambda () ,@body)))
 101
 102 (defpsmacro stringp (x)
 103   `(= (typeof ,x) "string"))
 104
 105 (defpsmacro numberp (x)
 106   `(= (typeof ,x) "number"))
 107
 108 (defpsmacro functionp (x)
 109   `(= (typeof ,x) "function"))
 110
 111 (defpsmacro objectp (x)
 112   `(= (typeof ,x) "object"))
 113
 114 (defpsmacro memoize (fn-expr)
 115   (destructuring-bind (defun fn-name (arg) &rest fn-body)
 116       fn-expr
 117     (declare (ignore defun))
 118     (with-ps-gensyms (table value compute-fn)
 119       `(let ((,table {}))
 120          (defun ,compute-fn (,arg) ,@fn-body)
 121          (defun ,fn-name (,arg)
 122            (let ((,value (aref ,table ,arg)))
 123              (when (null ,value)
 124                (setf ,value (,compute-fn ,arg))
 125                (setf (aref ,table ,arg) ,value))
 126              (return ,value)))))))
 127
 128 (defpsmacro append (arr1 &rest arrs)
 129   (if arrs
 130       `((@ ,arr1 :concat) ,@arrs)
 131       arr1))
 132
 133 (defpsmacro apply (fn &rest args)
 134   (let ((arglist (if (> (length args) 1)
 135                      `(append (list ,@(butlast args)) ,(car (last args)))
 136                      (first args))))
 137     `((@ ,fn :apply) this ,arglist)))
 138
 139 (defpsmacro destructuring-bind (vars expr &body body)
 140   ;; a simple implementation that for now only supports flat lists
 141   (let* ((arr (if (complex-js-expr-p expr) (ps-gensym) expr))
 142          (n -1)
 143          (bindings
 144           (append (unless (equal arr expr) `((,arr ,expr)))
 145                   (mapcar (lambda (var) `(,var (aref ,arr ,(incf n)))) vars))))
 146     `(let ,bindings ,@body)))