1 (in-package "PARENSCRIPT")
3 ;;; Handy utilities for doing common tasks found in many web browser
4 ;;; JavaScript implementations
6 (defpsmacro do-set-timeout
((timeout) &body body
)
7 `(set-timeout (lambda () ,@body
) ,timeout
))
11 (defmacro def-js-maths
(&rest mathdefs
)
12 `(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def
)) mathdefs
)))
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
))
34 (abs (n) `((@ *math abs
) ,n
))
35 (evenp (n) `(not (oddp ,n
)))
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
)))))
48 (define-ps-symbol-macro pi
(@ *math
*pi
*))
50 ;;; Exception handling
52 (defpsmacro ignore-errors
(&body body
)
53 `(try (progn ,@body
) (:catch
(e))))
57 (defpsmacro [] (&rest args
)
58 `(array ,@(mapcar (lambda (arg)
59 (if (and (consp arg
) (not (equal '[] (car arg
))))
64 (defpsmacro length
(a)
72 (defpsmacro undefined
(x)
75 (defpsmacro defined
(x)
76 `(not (undefined ,x
)))
78 (defpsmacro @ (obj &rest props
)
79 "Handy slot-value/aref composition macro."
81 `(@ (slot-value ,obj
,(if (symbolp (car props
)) `',(car props
) (car props
))) ,@(cdr props
))
84 (defpsmacro concatenate
(result-type &rest sequences
)
85 (assert (equal result-type
''string
) () "Right now Parenscript 'concatenate' only support strings.")
88 (defmacro concat-string
(&rest things
)
89 "Like concatenate but prints all of its arguments."
90 `(format nil
"~@{~A~}" ,@things
))
92 (defpsmacro concat-string
(&rest things
)
95 (defpsmacro elt
(array index
)
96 `(aref ,array
,index
))
98 (defpsmacro with-lambda
(() &body body
)
99 "Wraps BODY in a lambda so that it can be treated as an expression."
100 `((lambda () ,@body
)))
102 (defpsmacro stringp
(x)
103 `(= (typeof ,x
) "string"))
105 (defpsmacro numberp
(x)
106 `(= (typeof ,x
) "number"))
108 (defpsmacro functionp
(x)
109 `(= (typeof ,x
) "function"))
111 (defpsmacro objectp
(x)
112 `(= (typeof ,x
) "object"))
114 (defpsmacro memoize
(fn-expr)
115 (destructuring-bind (defun fn-name (arg) &rest fn-body
)
117 (declare (ignore defun
))
118 (with-ps-gensyms (table value compute-fn
)
120 (defun ,compute-fn
(,arg
) ,@fn-body
)
121 (defun ,fn-name
(,arg
)
122 (let ((,value
(aref ,table
,arg
)))
124 (setf ,value
(,compute-fn
,arg
))
125 (setf (aref ,table
,arg
) ,value
))
126 (return ,value
)))))))
128 (defpsmacro append
(arr1 &rest arrs
)
130 `((@ ,arr1
:concat
) ,@arrs
)
133 (defpsmacro apply
(fn &rest args
)
134 (let ((arglist (if (> (length args
) 1)
135 `(append (list ,@(butlast args
)) ,(car (last args
)))
137 `((@ ,fn
:apply
) this
,arglist
)))
139 (defpsmacro destructuring-bind
(vars expr
&body body
)
140 ;; a simple implementation that for now only supports flat lists,
141 ;; but does allow NIL bindings to indicate ignore (a la LOOP)
142 (let* ((arr (if (complex-js-expr? expr
) (ps-gensym) expr
))
145 (append (unless (equal arr expr
) `((,arr
,expr
)))
146 (mapcan (lambda (var)
148 (when var
`((,var
(aref ,arr
,n
))))) vars
))))
149 `(let* ,bindings
,@body
)))