X-Git-Url: https://git.hcoop.net/clinton/parenscript.git/blobdiff_plain/11fd716c568eae7c9e8cabd72b8a4da4b305ca04..96f55721757b51f3767573ded5ce46560acd6fa2:/src/lib/ps-macro-lib.lisp diff --git a/src/lib/ps-macro-lib.lisp b/src/lib/ps-macro-lib.lisp index 85ff59e..06ee713 100644 --- a/src/lib/ps-macro-lib.lisp +++ b/src/lib/ps-macro-lib.lisp @@ -1,4 +1,4 @@ -(in-package :parenscript) +(in-package "PARENSCRIPT") ;;; Handy utilities for doing common tasks found in many web browser ;;; JavaScript implementations @@ -12,17 +12,17 @@ `(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def)) mathdefs))) (def-js-maths - (max (&rest nums) `(*math.max ,@nums)) - (min (&rest nums) `(*math.min ,@nums)) - (floor (n &optional divisor) `(*math.floor ,(if divisor `(/ ,n ,divisor) n))) - (ceiling (n &optional divisor) `(*math.ceil ,(if divisor `(/ ,n ,divisor) n))) - (round (n &optional divisor) `(*math.round ,(if divisor `(/ ,n ,divisor) n))) - (sin (n) `(*math.sin ,n)) - (cos (n) `(*math.cos ,n)) - (tan (n) `(*math.tan ,n)) - (asin (n) `(*math.asin ,n)) - (acos (n) `(*math.acos ,n)) - (atan (y &optional x) (if x `(*math.atan2 ,y ,x) `(*math.atan ,y))) + (max (&rest nums) `((@ *math max) ,@nums)) + (min (&rest nums) `((@ *math min) ,@nums)) + (floor (n &optional divisor) `((@ *math floor) ,(if divisor `(/ ,n ,divisor) n))) + (ceiling (n &optional divisor) `((@ *math ceil) ,(if divisor `(/ ,n ,divisor) n))) + (round (n &optional divisor) `((@ *math round) ,(if divisor `(/ ,n ,divisor) n))) + (sin (n) `((@ *math sin) ,n)) + (cos (n) `((@ *math cos) ,n)) + (tan (n) `((@ *math tan) ,n)) + (asin (n) `((@ *math asin) ,n)) + (acos (n) `((@ *math acos) ,n)) + (atan (y &optional x) (if x `((@ *math atan2) ,y ,x) `((@ *math atan) ,y))) (sinh (n) `((lambda (x) (return (/ (- (exp x) (exp (- x))) 2))) ,n)) (cosh (n) `((lambda (x) (return (/ (+ (exp x) (exp (- x))) 2))) ,n)) (tanh (n) `((lambda (x) (return (/ (- (exp x) (exp (- x))) (+ (exp x) (exp (- x)))))) ,n)) @@ -31,21 +31,21 @@ (atanh (n) `((lambda (x) (return (/ (- (log (+ 1 x)) (log (- 1 x))) 2))) ,n)) (1+ (n) `(+ ,n 1)) (1- (n) `(- ,n 1)) - (abs (n) `(*math.abs ,n)) + (abs (n) `((@ *math abs) ,n)) (evenp (n) `(not (oddp ,n))) (oddp (n) `(% ,n 2)) - (exp (n) `(*math.exp ,n)) - (expt (base power) `(*math.pow ,base ,power)) + (exp (n) `((@ *math exp) ,n)) + (expt (base power) `((@ *math pow) ,base ,power)) (log (n &optional base) - (or (and (null base) `(*math.log ,n)) - (and (numberp base) (= base 10) `(* (log ,n) *math.*log10e*)) + (or (and (null base) `((@ *math log) ,n)) + (and (numberp base) (= base 10) `(* (log ,n) (@ *math *log10e*))) `(/ (log ,n) (log ,base)))) - (sqrt (n) `(*math.sqrt ,n)) + (sqrt (n) `((@ *math sqrt) ,n)) (random (&optional upto) (if upto - `(floor (* ,upto (*math.random))) - '(*math.random)))) + `(floor (* ,upto ((@ *math random)))) + '((@ *math random))))) -(define-script-symbol-macro pi '*math.*pi*) +(define-ps-symbol-macro pi (@ *math *pi*)) ;;; Exception handling @@ -54,26 +54,135 @@ ;;; Data structures +(defpsmacro [] (&rest args) + `(array ,@(mapcar (lambda (arg) + (if (and (consp arg) (not (equal '[] (car arg)))) + (cons '[] arg) + arg)) + args))) + (defpsmacro length (a) - `(.size ,a)) + `(@ ,a length)) ;;; Misc (defpsmacro null (x) `(= ,x nil)) +(defpsmacro undefined (x) + `(=== undefined ,x)) + +(defpsmacro defined (x) + `(not (undefined ,x))) + (defpsmacro @ (obj &rest props) "Handy slot-value/aref composition macro." - (if (null props) - obj - `(@ (slot-value - ,(if (stringp obj) `($ ,obj) obj) - ,(let ((prop (macroexpand (first props)))) - (if (symbolp prop) - `',prop - prop))) - ,@(cdr props)))) + (if props + `(@ (slot-value ,obj ,(if (symbolp (car props)) `',(car props) (car props))) ,@(cdr props)) + obj)) + +(defpsmacro chain (&rest method-calls) + (labels ((do-chain (method-calls) + (if (cdr method-calls) + (if (listp (car method-calls)) + `((@ ,(do-chain (cdr method-calls)) ,(caar method-calls)) ,@(cdar method-calls)) + `(@ ,(do-chain (cdr method-calls)) ,(car method-calls))) + (car method-calls)))) + (do-chain (reverse method-calls)))) + (defpsmacro concatenate (result-type &rest sequences) (assert (equal result-type ''string) () "Right now Parenscript 'concatenate' only support strings.") (cons '+ sequences)) + +(defmacro concat-string (&rest things) + "Like concatenate but prints all of its arguments." + `(format nil "~@{~A~}" ,@things)) + +(defpsmacro concat-string (&rest things) + (cons '+ things)) + +(defpsmacro elt (array index) + `(aref ,array ,index)) + +(defpsmacro with-lambda (() &body body) + "Wraps BODY in a lambda so that it can be treated as an expression." + `((lambda () ,@body))) + +(defpsmacro stringp (x) + `(= (typeof ,x) "string")) + +(defpsmacro numberp (x) + `(= (typeof ,x) "number")) + +(defpsmacro functionp (x) + `(= (typeof ,x) "function")) + +(defpsmacro objectp (x) + `(= (typeof ,x) "object")) + +(defpsmacro memoize (fn-expr) + (destructuring-bind (defun fn-name (arg) &rest fn-body) + fn-expr + (declare (ignore defun)) + (with-ps-gensyms (table value compute-fn) + `(let ((,table {})) + (defun ,compute-fn (,arg) ,@fn-body) + (defun ,fn-name (,arg) + (let ((,value (aref ,table ,arg))) + (when (null ,value) + (setf ,value (,compute-fn ,arg)) + (setf (aref ,table ,arg) ,value)) + (return ,value))))))) + +(defpsmacro append (arr1 &rest arrs) + (if arrs + `((@ ,arr1 concat) ,@arrs) + arr1)) + +(defpsmacro apply (fn &rest args) + (let ((arglist (if (> (length args) 1) + `(append (list ,@(butlast args)) ,(car (last args))) + (first args)))) + `((@ ,fn apply) this ,arglist))) + +(defun destructuring-wrap (arr n bindings body &key setf?) + (labels ((bind-expr (var expr inner-body) + (if setf? + `(progn (setf ,var ,expr) ,inner-body) + `(let ((,var ,expr)) ,inner-body))) + (bind-rest (sym) + (bind-expr sym `(when (> (length ,arr) ,n) + ((@ ,arr slice) ,n)) + body))) + (cond ((null bindings) + body) + ((atom bindings) ;; dotted destructuring list + (bind-rest bindings)) + ((eq (car bindings) '&rest) + (if (and (= (length bindings) 2) + (atom (second bindings))) + (bind-rest (second bindings)) + (error "~a is invalid in destructuring list." bindings))) + ((eq (car bindings) '&optional) + (destructuring-wrap arr n (cdr bindings) body :setf? setf?)) + (t (let ((var (car bindings)) + (inner-body (destructuring-wrap arr (1+ n) (cdr bindings) body :setf? setf?))) + (cond ((null var) inner-body) + ((atom var) (bind-expr var `(aref ,arr ,n) inner-body)) + (t `(,(if setf? 'dset 'destructuring-bind) + ,var (aref ,arr ,n) + ,inner-body)))))))) + +(defpsmacro dset (bindings expr &body body) + (let ((arr (if (complex-js-expr? expr) (ps-gensym) expr))) + `(progn + ,@(unless (eq arr expr) `((setf ,arr ,expr))) + ,(destructuring-wrap arr 0 bindings (cons 'progn body) :setf? t)))) + +(defpsmacro destructuring-bind (bindings expr &body body) + (let* ((arr (if (complex-js-expr? expr) (ps-gensym) expr)) + (bound (destructuring-wrap arr 0 bindings (cons 'progn body)))) + (if (eq arr expr) + bound + `(let ((,arr ,expr)) ,bound))))