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
)
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
62 (defmacro def-js-maths
(&rest mathdefs
)
63 `(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def
)) mathdefs
)))
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
)))
82 `(/ (- (exp ,x
) (exp (- ,x
))) 2)))
85 `(/ (+ (exp ,x
) (exp (- ,x
))) 2)))
88 `(/ (- (exp ,x
) (exp (- ,x
))) (+ (exp ,x
) (exp (- ,x
))))))
91 `(log (+ ,x
(sqrt (1+ (* ,x
,x
)))))))
94 `(* 2 (log (+ (sqrt (/ (1+ ,x
) 2)) (sqrt (/ (1- ,x
) 2)))))))
95 (atanh (x) ;; real only for -1 < x < 1, otherwise complex
97 `(/ (- (log (+ 1 ,x
)) (log (- 1 ,x
))) 2)))
100 `(rem (+ (rem ,x
,n
) ,n
) ,n
)))
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)
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
))
128 (<< ,integer
,count-var
)
129 (>> ,integer
(- ,count-var
))))))
132 (>> ,integer
(- ,count
)))))))
134 (define-ps-symbol-macro pi
(getprop *math
'*pi
*))
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
)
156 (defpsmacro arrayp
(x)
161 (defpsmacro make-array
(&rest args
)
163 (destructuring-bind (dim &key
(initial-element nil initial-element-p
)
164 initial-contents element-type
)
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
))))))
180 `(new (*array
,@args
))))
182 (defpsmacro length
(a)
183 `(getprop ,a
'length
))
187 (defpsmacro with-slots
(slots object
&rest body
)
188 (flet ((slot-var (slot)
196 (maybe-once-only (object)
197 `(symbol-macrolet ,(mapcar (lambda (slot)
198 `(,(slot-var slot
) (getprop ,object
',(slot-symbol slot
))))
204 (defpsmacro multiple-value-bind
(vars form
&body body
)
205 (let* ((form (ps-macroexpand form
))
206 (progn-form (when (and (consp form
)
208 '(with label let flet labels
209 macrolet symbol-macrolet progn
)))
214 (multiple-value-bind ,vars
217 ;; assume function call
219 (setf __PS_MV_REG
'())
220 (let ((,(car vars
) ,form
))
221 (destructuring-bind (&optional
,@(cdr vars
))
225 (defpsmacro multiple-value-list
(form)
226 (with-ps-gensyms (first-value values-list
)
227 `(let* ((,first-value
(progn
228 (setf __PS_MV_REG
'())
230 (,values-list
(funcall (getprop __PS_MV_REG
'slice
))))
231 (funcall (getprop ,values-list
'unshift
) ,first-value
)
236 (defpsmacro case
(value &rest clauses
)
238 ((make-switch-clause (val body more
)
240 (append (mapcar #'list
(butlast val
))
242 (if (eq t
(car (last val
))) ;; literal 'true'
247 `((,(cond ((member val
'(t otherwise
)) 'default
)
249 ((eql val
'false
) 'false
)
251 ((symbolp val
) (list 'quote val
))
254 ,@(when more
'(break)))))))
256 ,@(mapcon (lambda (clause)
257 (make-switch-clause (car (first clause
))
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.
274 [&optional {var | (var [init-form [supplied-p-parameter]])}*]
276 [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
277 [&aux {var | (var [init-form])}*])"
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
*)
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
308 (let* ((,store-var
(ps-gensym))
309 (gensymed-names (loop repeat
,(length var-bindings
)
310 collecting
(ps-gensym)))
311 (gensymed-arg-bindings (mapcar #'list
313 (list ,@var-bindings
))))
314 (destructuring-bind ,var-bindings
316 `(let* (,@gensymed-arg-bindings
317 (,,store-var
,store-form
))
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
)))
328 (defpsmacro defsetf
(access-fn &rest args
)
329 `(,(if (= (length args
) 3) 'defsetf-long
'defsetf-short
) ,access-fn
,@args
))
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
)))
352 (error 'type-error
:datum non-var
:expected-type
'symbol
)))))
354 (defpsmacro setq
(&rest args
)
355 (check-setq-args args
)
358 (defpsmacro psetq
(&rest args
)
359 (check-setq-args args
)
364 (defun do-make-iteration-bindings (decls)
367 ((endp (cdr x
)) (list (car x
)))
371 (defun do-make-for-steps (decls)
373 `(setf ,(first x
) ,(third x
)))
374 (remove-if (lambda (x)
375 (or (atom x
) (< (length x
) 3)))
378 (defun do-make-iter-psteps (decls)
380 ,@(mapcan (lambda (x)
381 (list (first x
) (third x
)))
382 (remove-if (lambda (x)
383 (or (atom x
) (< (length x
) 3)))
386 (defpsmacro do
* (decls (end-test &optional
(result nil result?
)) &body body
)
388 (for ,(do-make-iteration-bindings decls
)
390 ,(do-make-for-steps decls
)
392 ,@(when result?
(list result
))))
394 (defpsmacro do
(decls (end-test &optional
(result nil result?
)) &body body
)
395 (multiple-value-bind (do-body declarations
)
398 (let ,(do-make-iteration-bindings decls
)
400 (for () ((not ,end-test
)) ()
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
)))
408 ,@(when result?
`((let ((,var nil
)) ,result
))))
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
)
418 ,@(when introduce-array-var?
419 (list (list arrvar array
)))
421 ((>= ,idx
(getprop ,arrvar
'length
))
422 ,@(when result?
`((let ((,var nil
)) ,result
))))
423 (setq ,var
(aref ,arrvar
,idx
))
428 (defpsmacro concatenate
(result-type &rest sequences
)
429 (assert (equal result-type
''string
) () "Right now Parenscript 'concatenate' only support strings.")
432 (defpsmacro append
(arr1 &rest arrs
)
434 `((@ ,arr1 concat
) ,@arrs
)
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
)))
454 (let ((vars* (remove var
(rest spec
))))
455 (if (eq vars
* (cdr spec
))
458 (pushnew var
(getf var-declarations
'special
))
459 (cons 'special vars
*))))
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
))
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
))
482 (t `(,'destructuring-bind
,var
(aref ,arr
,n
)
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
)
502 `(try (progn ,@forms
)
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
)))
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
)))
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
))))
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
))
539 then
`((let (,binding
)
540 (declare ,@(pop-declarations-for-var var declarations
))
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
)))))