Commit | Line | Data |
---|---|---|
5ffb1eba | 1 | (in-package "PARENSCRIPT") |
3eb7802d VS |
2 | |
3 | ;;; Handy utilities for doing common tasks found in many web browser | |
4 | ;;; JavaScript implementations | |
5 | ||
4a987e2b | 6 | (defpsmacro do-set-timeout ((timeout) &body body) |
3eb7802d VS |
7 | `(set-timeout (lambda () ,@body) ,timeout)) |
8 | ||
9 | ;;; Arithmetic | |
10 | ||
11 | (defmacro def-js-maths (&rest mathdefs) | |
4a987e2b | 12 | `(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def)) mathdefs))) |
3eb7802d VS |
13 | |
14 | (def-js-maths | |
5ffb1eba VS |
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))) | |
a1abb4e4 TC |
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)) | |
8b9d8bc7 TC |
32 | (1+ (n) `(+ ,n 1)) |
33 | (1- (n) `(- ,n 1)) | |
5ffb1eba | 34 | (abs (n) `((@ *math abs) ,n)) |
9b89687a TC |
35 | (evenp (n) `(not (oddp ,n))) |
36 | (oddp (n) `(% ,n 2)) | |
5ffb1eba VS |
37 | (exp (n) `((@ *math exp) ,n)) |
38 | (expt (base power) `((@ *math pow) ,base ,power)) | |
9a2c0f23 | 39 | (log (n &optional base) |
5ffb1eba VS |
40 | (or (and (null base) `((@ *math log) ,n)) |
41 | (and (numberp base) (= base 10) `(* (log ,n) (@ *math *log10e*))) | |
9a2c0f23 | 42 | `(/ (log ,n) (log ,base)))) |
5ffb1eba | 43 | (sqrt (n) `((@ *math sqrt) ,n)) |
3eb7802d | 44 | (random (&optional upto) (if upto |
5ffb1eba VS |
45 | `(floor (* ,upto ((@ *math random)))) |
46 | '((@ *math random))))) | |
854b1c7e | 47 | |
5ffb1eba | 48 | (define-ps-symbol-macro pi (@ *math *pi*)) |
11fd716c | 49 | |
854b1c7e VS |
50 | ;;; Exception handling |
51 | ||
4a987e2b | 52 | (defpsmacro ignore-errors (&body body) |
854b1c7e | 53 | `(try (progn ,@body) (:catch (e)))) |
2e51aff5 | 54 | |
c72e87d8 VS |
55 | ;;; Data structures |
56 | ||
06ed0d3a VS |
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 | ||
c72e87d8 | 64 | (defpsmacro length (a) |
3366794f | 65 | `(@ ,a length)) |
c72e87d8 | 66 | |
2e51aff5 VS |
67 | ;;; Misc |
68 | ||
69 | (defpsmacro null (x) | |
70 | `(= ,x nil)) | |
c72e87d8 | 71 | |
83a26b36 DG |
72 | (defpsmacro undefined (x) |
73 | `(=== undefined ,x)) | |
74 | ||
75 | (defpsmacro defined (x) | |
76 | `(not (undefined ,x))) | |
77 | ||
c72e87d8 VS |
78 | (defpsmacro @ (obj &rest props) |
79 | "Handy slot-value/aref composition macro." | |
7ac25d0d VS |
80 | (if props |
81 | `(@ (slot-value ,obj ,(if (symbolp (car props)) `',(car props) (car props))) ,@(cdr props)) | |
82 | obj)) | |
d5c9059a | 83 | |
d9d9a970 VS |
84 | (defpsmacro chain (&rest method-calls) |
85 | (labels ((do-chain (method-calls) | |
86 | (if (cdr method-calls) | |
87 | `((@ ,(do-chain (cdr method-calls)) ,(caar method-calls)) ,@(cdar method-calls)) | |
88 | (car method-calls)))) | |
89 | (do-chain (reverse method-calls)))) | |
90 | ||
91 | ||
d5c9059a VS |
92 | (defpsmacro concatenate (result-type &rest sequences) |
93 | (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.") | |
94 | (cons '+ sequences)) | |
1937c30a VS |
95 | |
96 | (defmacro concat-string (&rest things) | |
bb8ba95a | 97 | "Like concatenate but prints all of its arguments." |
1937c30a VS |
98 | `(format nil "~@{~A~}" ,@things)) |
99 | ||
100 | (defpsmacro concat-string (&rest things) | |
101 | (cons '+ things)) | |
102 | ||
ce44c98c VS |
103 | (defpsmacro elt (array index) |
104 | `(aref ,array ,index)) | |
f61db7bb DG |
105 | |
106 | (defpsmacro with-lambda (() &body body) | |
107 | "Wraps BODY in a lambda so that it can be treated as an expression." | |
108 | `((lambda () ,@body))) | |
83a26b36 DG |
109 | |
110 | (defpsmacro stringp (x) | |
111 | `(= (typeof ,x) "string")) | |
112 | ||
113 | (defpsmacro numberp (x) | |
114 | `(= (typeof ,x) "number")) | |
115 | ||
116 | (defpsmacro functionp (x) | |
117 | `(= (typeof ,x) "function")) | |
118 | ||
119 | (defpsmacro objectp (x) | |
120 | `(= (typeof ,x) "object")) | |
121 | ||
122 | (defpsmacro memoize (fn-expr) | |
123 | (destructuring-bind (defun fn-name (arg) &rest fn-body) | |
124 | fn-expr | |
125 | (declare (ignore defun)) | |
126 | (with-ps-gensyms (table value compute-fn) | |
127 | `(let ((,table {})) | |
128 | (defun ,compute-fn (,arg) ,@fn-body) | |
129 | (defun ,fn-name (,arg) | |
130 | (let ((,value (aref ,table ,arg))) | |
131 | (when (null ,value) | |
132 | (setf ,value (,compute-fn ,arg)) | |
133 | (setf (aref ,table ,arg) ,value)) | |
134 | (return ,value))))))) | |
135 | ||
136 | (defpsmacro append (arr1 &rest arrs) | |
137 | (if arrs | |
138 | `((@ ,arr1 :concat) ,@arrs) | |
139 | arr1)) | |
140 | ||
141 | (defpsmacro apply (fn &rest args) | |
142 | (let ((arglist (if (> (length args) 1) | |
143 | `(append (list ,@(butlast args)) ,(car (last args))) | |
144 | (first args)))) | |
145 | `((@ ,fn :apply) this ,arglist))) | |
146 | ||
147 | (defpsmacro destructuring-bind (vars expr &body body) | |
6e135d5c DG |
148 | ;; a simple implementation that for now only supports flat lists, |
149 | ;; but does allow NIL bindings to indicate ignore (a la LOOP) | |
98b0b244 | 150 | (let* ((arr (if (complex-js-expr? expr) (ps-gensym) expr)) |
83a26b36 DG |
151 | (n -1) |
152 | (bindings | |
153 | (append (unless (equal arr expr) `((,arr ,expr))) | |
6e135d5c DG |
154 | (mapcan (lambda (var) |
155 | (incf n) | |
156 | (when var `((,var (aref ,arr ,n))))) vars)))) | |
998d9a7d | 157 | `(let* ,bindings ,@body))) |