Updated copyright year on the reference manual
[parenscript.git] / src / macros.lisp
blobddcffbbc4c9708b42a2ec9196a68cf03bc456e18
1 ;;;; -*- encoding:utf-8 -*-
3 ;;; Copyright 2005 Manuel Odendahl
4 ;;; Copyright 2005-2006 Edward Marco Baringer
5 ;;; Copyright 2006 Luca Capello
6 ;;; Copyright 2010-2012 Vladimir Sedach
7 ;;; Copyright 2010-2013 Daniel Gackle
8 ;;; Copyright 2012, 2014 Boris Smilga
10 ;;; SPDX-License-Identifier: BSD-3-Clause
12 ;;; Redistribution and use in source and binary forms, with or
13 ;;; without modification, are permitted provided that the following
14 ;;; conditions are met:
16 ;;; 1. Redistributions of source code must retain the above copyright
17 ;;; notice, this list of conditions and the following disclaimer.
19 ;;; 2. Redistributions in binary form must reproduce the above
20 ;;; copyright notice, this list of conditions and the following
21 ;;; disclaimer in the documentation and/or other materials provided
22 ;;; with the distribution.
24 ;;; 3. Neither the name of the copyright holder nor the names of its
25 ;;; contributors may be used to endorse or promote products derived
26 ;;; from this software without specific prior written permission.
28 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
29 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
30 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
31 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
32 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
33 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
34 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
35 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
36 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
37 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
38 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
39 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
40 ;;; POSSIBILITY OF SUCH DAMAGE.
42 (in-package #:parenscript)
43 (named-readtables:in-readtable :parenscript)
45 (macrolet ((define-trivial-mappings (&rest mappings)
46 `(progn
47 ,@(loop for (macro-name ps-op) on mappings by #'cddr collect
48 `(defpsmacro ,macro-name (&rest args)
49 (cons ',ps-op args))))))
50 (define-trivial-mappings
51 string= eql
52 eq eql
53 = eql
54 list array
55 elt aref))
57 (defpsmacro null (x)
58 `(equal ,x nil))
60 ;;; Math
62 (defmacro def-js-maths (&rest mathdefs)
63 `(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def)) mathdefs)))
65 (def-js-maths
66 (max (&rest nums) `((@ *math max) ,@nums))
67 (min (&rest nums) `((@ *math min) ,@nums))
68 (floor (n &optional divisor)
69 `((@ *math floor) ,(if divisor `(/ ,n ,divisor) n)))
70 (ceiling (n &optional divisor)
71 `((@ *math ceil) ,(if divisor `(/ ,n ,divisor) n)))
72 (round (n &optional divisor)
73 `((@ *math round) ,(if divisor `(/ ,n ,divisor) n)))
74 (sin (n) `((@ *math sin) ,n))
75 (cos (n) `((@ *math cos) ,n))
76 (tan (n) `((@ *math tan) ,n))
77 (asin (n) `((@ *math asin) ,n))
78 (acos (n) `((@ *math acos) ,n))
79 (atan (y &optional x) (if x `((@ *math atan2) ,y ,x) `((@ *math atan) ,y)))
80 (sinh (x)
81 (maybe-once-only (x)
82 `(/ (- (exp ,x) (exp (- ,x))) 2)))
83 (cosh (x)
84 (maybe-once-only (x)
85 `(/ (+ (exp ,x) (exp (- ,x))) 2)))
86 (tanh (x)
87 (maybe-once-only (x)
88 `(/ (- (exp ,x) (exp (- ,x))) (+ (exp ,x) (exp (- ,x))))))
89 (asinh (x)
90 (maybe-once-only (x)
91 `(log (+ ,x (sqrt (1+ (* ,x ,x)))))))
92 (acosh (x)
93 (maybe-once-only (x)
94 `(* 2 (log (+ (sqrt (/ (1+ ,x) 2)) (sqrt (/ (1- ,x) 2)))))))
95 (atanh (x) ;; real only for -1 < x < 1, otherwise complex
96 (maybe-once-only (x)
97 `(/ (- (log (+ 1 ,x)) (log (- 1 ,x))) 2)))
98 (mod (x n)
99 (maybe-once-only (n)
100 `(rem (+ (rem ,x ,n) ,n) ,n)))
101 (1+ (n) `(+ ,n 1))
102 (1- (n) `(- ,n 1))
103 (abs (n) `((@ *math abs) ,n))
104 (evenp (n) `(not (oddp ,n)))
105 (oddp (n) `(rem ,n 2))
106 (exp (n) `((@ *math exp) ,n))
107 (expt (base power) `((@ *math pow) ,base ,power))
108 (log (n &optional base)
109 (or (and (null base) `((@ *math log) ,n))
110 (and (numberp base) (= base 10) `(* (log ,n) (@ *math *log10e*)))
111 `(/ (log ,n) (log ,base))))
112 (sqrt (n) `((@ *math sqrt) ,n))
113 (random (&optional upto) (if upto
114 (maybe-once-only (upto)
115 `(if (rem ,upto 1)
116 (* ,upto (random))
117 (floor (* ,upto (random)))))
118 '(funcall (@ *math random)))))
120 (defpsmacro ash (integer count)
121 (let ((count (ps-macroexpand count)))
122 (cond ((and (numberp count) (> count 0)) `(<< ,integer ,count))
123 ((numberp count) `(>> ,integer ,(- count)))
124 ((complex-js-expr? count)
125 (let ((count-var (ps-gensym)))
126 `(let ((,count-var ,count))
127 (if (> ,count-var 0)
128 (<< ,integer ,count-var)
129 (>> ,integer (- ,count-var))))))
130 (t `(if (> ,count 0)
131 (<< ,integer ,count)
132 (>> ,integer (- ,count)))))))
134 (define-ps-symbol-macro pi (getprop *math '*pi*))
136 ;;; Types
138 (defpsmacro stringp (x)
139 `(string= (typeof ,x) "string"))
141 (defpsmacro numberp (x)
142 `(string= (typeof ,x) "number"))
144 (defpsmacro functionp (x)
145 `(string= (typeof ,x) "function"))
147 (defpsmacro booleanp (x)
148 `(string= (typeof ,x) "boolean"))
150 (defpsmacro listp (x)
151 (if (js-target-at-least "1.8.5")
152 `(funcall (getprop Array 'is-array) ,x)
153 `(string= (funcall (getprop Object 'prototype 'to-string 'call) ,x)
154 "[object Array]")))
156 (defpsmacro arrayp (x)
157 `(listp ,x))
159 ;;; Data structures
161 (defpsmacro make-array (&rest args)
162 (or (ignore-errors
163 (destructuring-bind (dim &key (initial-element nil initial-element-p)
164 initial-contents element-type)
165 args
166 (declare (ignore element-type))
167 (and (or initial-element-p initial-contents)
168 (not (and initial-element-p initial-contents))
169 (with-ps-gensyms (arr init elt i)
170 `(let ((,arr (new (*array ,dim))))
171 ,@(when initial-element-p
172 `((let ((,elt ,initial-element))
173 (dotimes (,i (length ,arr))
174 (setf (aref ,arr ,i) ,elt)))))
175 ,@(when initial-contents
176 `((let ((,init ,initial-contents))
177 (dotimes (,i (min (length ,arr) (length ,init)))
178 (setf (aref ,arr ,i) (aref ,init ,i))))))
179 ,arr)))))
180 `(new (*array ,@args))))
182 (defpsmacro length (a)
183 `(getprop ,a 'length))
185 ;;; Getters
187 (defpsmacro with-slots (slots object &rest body)
188 (flet ((slot-var (slot)
189 (if (listp slot)
190 (first slot)
191 slot))
192 (slot-symbol (slot)
193 (if (listp slot)
194 (second slot)
195 slot)))
196 (maybe-once-only (object)
197 `(symbol-macrolet ,(mapcar (lambda (slot)
198 `(,(slot-var slot) (getprop ,object ',(slot-symbol slot))))
199 slots)
200 ,@body))))
202 ;;; multiple values
204 (defpsmacro multiple-value-bind (vars form &body body)
205 (let* ((form (ps-macroexpand form))
206 (progn-form (when (and (consp form)
207 (member (car form)
208 '(with label let flet labels
209 macrolet symbol-macrolet progn)))
210 (pop form))))
211 (if progn-form
212 `(,progn-form
213 ,@(butlast form)
214 (multiple-value-bind ,vars
215 ,@(last form)
216 ,@body))
217 ;; assume function call
218 `(progn
219 (setf __PS_MV_REG '())
220 (let ((,(car vars) ,form))
221 (destructuring-bind (&optional ,@(cdr vars))
222 __PS_MV_REG
223 ,@body))))))
225 (defpsmacro multiple-value-list (form)
226 (with-ps-gensyms (first-value values-list)
227 `(let* ((,first-value (progn
228 (setf __PS_MV_REG '())
229 ,form))
230 (,values-list (funcall (getprop __PS_MV_REG 'slice))))
231 (funcall (getprop ,values-list 'unshift) ,first-value)
232 ,values-list)))
234 ;;; conditionals
236 (defpsmacro case (value &rest clauses)
237 (labels
238 ((make-switch-clause (val body more)
239 (if (consp val)
240 (append (mapcar #'list (butlast val))
241 (make-switch-clause
242 (if (eq t (car (last val))) ;; literal 'true'
243 '%true
244 (car (last val)))
245 body
246 more))
247 `((,(cond ((member val '(t otherwise)) 'default)
248 ((eql val '%true) t)
249 ((eql val 'false) 'false)
250 ((null val) 'false)
251 ((symbolp val) (list 'quote val))
252 (t val))
253 ,@body
254 ,@(when more '(break)))))))
255 `(switch ,value
256 ,@(mapcon (lambda (clause)
257 (make-switch-clause (car (first clause))
258 (cdr (first clause))
259 (rest clause)))
260 clauses))))
262 (defpsmacro when (test &rest body)
263 `(if ,test (progn ,@body)))
265 (defpsmacro unless (test &rest body)
266 `(when (not ,test) ,@body))
268 ;;; function definition
270 (defpsmacro defun (name lambda-list &body body)
271 "An extended defun macro that allows cool things like keyword arguments.
272 lambda-list::=
273 (var*
274 [&optional {var | (var [init-form [supplied-p-parameter]])}*]
275 [&rest var]
276 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
277 [&aux {var | (var [init-form])}*])"
278 (if (symbolp name)
279 (progn (setf (gethash name *function-lambda-list*) lambda-list)
280 `(defun% ,name ,lambda-list ,@body))
281 (progn (assert (and (listp name) (= (length name) 2) (eq 'setf (car name))) ()
282 "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
283 `(defun-setf ,(second name) ,lambda-list ,@body))))
285 ;;; defining setf expanders
287 (defvar *defun-setf-name-prefix* '__setf_)
289 (defpsmacro defun-setf (name lambda-list &body body)
290 (let ((mangled-function-name
291 (intern (format nil "~A~A" (string *defun-setf-name-prefix*) (string name))
292 (symbol-package name))))
293 (setf (gethash name *setf-expanders*)
294 (lambda (access-args store-form)
295 `(,mangled-function-name ,store-form ,@access-args)))
296 `(defun ,mangled-function-name ,lambda-list ,@body)))
298 ;;; slightly broken WRT lambda lists
299 (defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
300 (setf (gethash access-fn *setf-expanders*)
301 (compile
303 (let ((var-bindings (ordered-set-difference lambda-list
304 lambda-list-keywords)))
305 `(lambda (access-fn-args store-form)
306 (destructuring-bind ,lambda-list
307 access-fn-args
308 (let* ((,store-var (ps-gensym))
309 (gensymed-names (loop repeat ,(length var-bindings)
310 collecting (ps-gensym)))
311 (gensymed-arg-bindings (mapcar #'list
312 gensymed-names
313 (list ,@var-bindings))))
314 (destructuring-bind ,var-bindings
315 gensymed-names
316 `(let* (,@gensymed-arg-bindings
317 (,,store-var ,store-form))
318 ,,form))))))))
319 nil)
321 (defpsmacro defsetf-short (access-fn update-fn &optional docstring)
322 (declare (ignore docstring))
323 (setf (gethash access-fn *setf-expanders*)
324 (lambda (access-fn-args store-form)
325 `(,update-fn ,@access-fn-args ,store-form)))
326 nil)
328 (defpsmacro defsetf (access-fn &rest args)
329 `(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
331 ;;; setf
333 (defpsmacro setf (&rest args)
334 (assert (evenp (length args)) ()
335 "~s does not have an even number of arguments." `(setf ,args))
336 `(progn ,@(loop for (place value) on args by #'cddr collect
337 (aif (and (listp place) (gethash (car place) *setf-expanders*))
338 (funcall it (cdr place) value)
339 `(ps-assign ,place ,value)))))
341 (defpsmacro psetf (&rest args)
342 (let ((places (loop for x in args by #'cddr collect x))
343 (vals (loop for x in (cdr args) by #'cddr collect x)))
344 (let ((gensyms (loop repeat (length places) collect (ps-gensym))))
345 `(let ,(mapcar #'list gensyms vals)
346 (setf ,@(mapcan #'list places gensyms))))))
348 (defun check-setq-args (args)
349 (let ((vars (loop for x in args by #'cddr collect x)))
350 (let ((non-var (find-if (complement #'symbolp) vars)))
351 (when non-var
352 (error 'type-error :datum non-var :expected-type 'symbol)))))
354 (defpsmacro setq (&rest args)
355 (check-setq-args args)
356 `(setf ,@args))
358 (defpsmacro psetq (&rest args)
359 (check-setq-args args)
360 `(psetf ,@args))
362 ;;; iteration
364 (defun do-make-iteration-bindings (decls)
365 (mapcar (lambda (x)
366 (cond ((atom x) x)
367 ((endp (cdr x)) (list (car x)))
368 (t (subseq x 0 2))))
369 decls))
371 (defun do-make-for-steps (decls)
372 (mapcar (lambda (x)
373 `(setf ,(first x) ,(third x)))
374 (remove-if (lambda (x)
375 (or (atom x) (< (length x) 3)))
376 decls)))
378 (defun do-make-iter-psteps (decls)
379 `(psetq
380 ,@(mapcan (lambda (x)
381 (list (first x) (third x)))
382 (remove-if (lambda (x)
383 (or (atom x) (< (length x) 3)))
384 decls))))
386 (defpsmacro do* (decls (end-test &optional (result nil result?)) &body body)
387 `(block nil
388 (for ,(do-make-iteration-bindings decls)
389 ((not ,end-test))
390 ,(do-make-for-steps decls)
391 (locally ,@body))
392 ,@(when result? (list result))))
394 (defpsmacro do (decls (end-test &optional (result nil result?)) &body body)
395 (multiple-value-bind (do-body declarations)
396 (parse-body body)
397 `(block nil
398 (let ,(do-make-iteration-bindings decls)
399 ,@declarations
400 (for () ((not ,end-test)) ()
401 ,@do-body
402 ,(do-make-iter-psteps decls))
403 ,@(when result? (list result))))))
405 (defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
406 `(do* ((,var 0 (1+ ,var)))
407 ((>= ,var ,count)
408 ,@(when result? `((let ((,var nil)) ,result))))
409 ,@body))
411 (defpsmacro dolist ((var array &optional (result nil result?)) &body body)
412 (let* ((idx (ps-gensym '_js_idx))
413 (introduce-array-var? (not (symbolp array)))
414 (arrvar (if introduce-array-var?
415 (ps-gensym '_js_arrvar)
416 array)))
417 `(do* (,var
418 ,@(when introduce-array-var?
419 (list (list arrvar array)))
420 (,idx 0 (1+ ,idx)))
421 ((>= ,idx (getprop ,arrvar 'length))
422 ,@(when result? `((let ((,var nil)) ,result))))
423 (setq ,var (aref ,arrvar ,idx))
424 ,@body)))
426 ;;; Concatenation
428 (defpsmacro concatenate (result-type &rest sequences)
429 (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.")
430 (cons '+ sequences))
432 (defpsmacro append (arr1 &rest arrs)
433 (if arrs
434 `((@ ,arr1 concat) ,@arrs)
435 arr1))
437 ;;; Destructuring bind
439 (defun complex-js-expr? (expr)
440 (consp (if (symbolp expr) (ps-macroexpand expr) expr)))
442 (defun hoist-expr? (bindings expr)
443 (and (> (length bindings) 1) (complex-js-expr? expr)))
445 (defun pop-declarations-for-var (var declarations)
446 (loop for declarations* on declarations
447 with var-declarations = nil
448 do (setf (first declarations*)
449 (loop for spec in (first declarations*)
450 ;; We only care for SPECIAL declarations for now
451 ;; (cf. WITH-DECLARATION-EFFECTS)
452 if (and (consp spec) (eq 'special (first spec)))
453 collect
454 (let ((vars* (remove var (rest spec))))
455 (if (eq vars* (cdr spec))
456 spec
457 (progn
458 (pushnew var (getf var-declarations 'special))
459 (cons 'special vars*))))
460 else
461 collect spec))
462 finally (return
463 (loop for (sym decls) on var-declarations by #'cddr
464 collect (cons sym decls)))))
466 (defun destructuring-wrap (arr n bindings declarations body)
467 (cond ((null bindings) body)
468 ((eq (car bindings) '&rest)
469 (cond ((and (= (length bindings) 2) (atom (second bindings)))
470 `(let ((,(second bindings) (if (> (length ,arr) ,n) ((@ ,arr slice) ,n) '())))
471 (declare ,@(pop-declarations-for-var (second bindings) declarations))
472 ,body))
473 (t (error "~a is invalid in destructuring list." bindings))))
474 ((eq (car bindings) '&optional)
475 (destructuring-wrap arr n (cdr bindings) declarations body))
476 (t (let ((var (car bindings))
477 (inner-body (destructuring-wrap arr (1+ n) (cdr bindings) declarations body)))
478 (cond ((null var) inner-body)
479 ((atom var) `(let ((,var (aref ,arr ,n)))
480 (declare ,@(pop-declarations-for-var var declarations))
481 ,inner-body))
482 (t `(,'destructuring-bind ,var (aref ,arr ,n)
483 ,@declarations
484 ,inner-body)))))))
486 (defpsmacro destructuring-bind (bindings expr &body body)
487 (setf bindings (dot->rest bindings))
488 (multiple-value-bind (body1 declarations) (parse-body body)
489 (let* ((arr (if (hoist-expr? bindings expr) (ps-gensym '_db) expr))
490 (bound (destructuring-wrap arr 0 bindings declarations
491 (cons 'progn body1))))
492 (cond ((eq arr expr) bound)
493 (t `(let ((,arr ,expr)) ,bound))))))
495 ;;; Control structures
497 (defpsmacro return (&optional result)
498 `(return-from nil ,result))
500 (defpsmacro ignore-errors (&body forms)
501 (with-ps-gensyms (e)
502 `(try (progn ,@forms)
503 (:catch (,e) nil))))
505 (defpsmacro unwind-protect (protected-form cleanup-form)
506 `(try ,protected-form
507 (:finally ,cleanup-form)))
509 (defpsmacro prog1 (first &rest others)
510 (with-ps-gensyms (val)
511 `(let ((,val (multiple-value-list ,first)))
512 ,@others
513 (values-list ,val))))
515 (defpsmacro prog2 (first second &rest others)
516 `(progn ,first (prog1 ,second ,@others)))
518 (defpsmacro apply (fn &rest args)
519 (let ((arglist (if (> (length args) 1)
520 `(append (list ,@(butlast args)) ,(car (last args)))
521 (first args))))
522 (if (and (listp fn)
523 (find (car fn) #(getprop chain @)))
524 (if (and (= (length fn) 3) (symbolp (second fn)))
525 `(funcall (getprop ,fn 'apply) ,(second fn) ,arglist)
526 (let ((obj (ps-gensym)) (method (ps-gensym)))
527 `(let* ((,obj ,(butlast fn))
528 (,method (,(car fn) ,obj ,(car (last fn)))))
529 (funcall (getprop ,method 'apply) ,obj ,arglist))))
530 `(funcall (getprop ,fn 'apply) this ,arglist))))
532 ;;; misc
534 (defpsmacro let* (bindings &body body)
535 (multiple-value-bind (let-body declarations) (parse-body body)
536 (loop for binding in (cons nil (reverse bindings))
537 for var = (if (symbolp binding) binding (car binding))
538 for body = let-body
539 then `((let (,binding)
540 (declare ,@(pop-declarations-for-var var declarations))
541 ,@body))
542 finally (return `(progn ,@body)))))
544 (defpsmacro in-package (package-designator)
545 `(eval-when (:compile-toplevel)
546 (in-package ,package-designator)))
548 (defpsmacro use-package (package-designator &optional package)
549 `(eval-when (:compile-toplevel)
550 (use-package ,package-designator ,@(when package (list package)))))