2 lines
40 KiB
Common Lisp
2 lines
40 KiB
Common Lisp
'(r-expressions (r-call library MASS) (r-call dyn.load "starp.so") (<- ppcommand (lambda (...) (let nil (r-block (r-call .Call "ppcommand" (r-call list r-dotdotdot)))))) (<- ppvcommand (lambda (va) (let nil (r-block (r-call .Call "ppcommand" va))))) (<- ppinvoke ppcommand) (<- pploadconfig (lambda (fileName) (let nil (r-block (r-call .Call "pploadconfig" fileName))))) (<- ppconnect (lambda (numProcs machines) (let ((machines nil) (numProcs nil)) (r-block (when (missing numProcs) (<- numProcs nil)) (when (missing machines) (<- machines nil)) (r-call .Call "ppconnect" (r-call list numProcs machines)))))) (<- ppgetlogpath (lambda nil (let nil (r-block (r-call .Call "ppgetlogpath"))))) (<- ppgetlog (lambda nil (let nil (r-block (r-call .Call "ppgetlog"))))) (<- ppshowdashboard (lambda nil (let nil (r-block (r-call .Call "ppshowdashboard"))))) (<- pphidedashboard (lambda nil (let nil (r-block (r-call .Call "pphidedashboard"))))) (<- revealargs (lambda (dots) (let nil (r-block (r-call .Call "_revealArgs" dots))))) (<- listargs (lambda (...) (let nil (r-block (r-call revealargs (r-call get "...")))))) (<- ppping (lambda nil (let nil (r-block (r-call ppcommand "ppping"))))) (<- ppver (lambda nil (let nil (r-block (r-call ppcommand "pp_ver"))))) (<- STARPDIST "../../../linkdist") (<- STARPPLATFORM "ia32_linux") (r-call .Call "_setstarpdist" STARPDIST) (r-call .Call "_setstarpplat" STARPPLATFORM) (r-call pploadconfig (r-call paste STARPDIST "/config/starpd.properties" (*named* sep ""))) (<- dimdis (lambda (v) (let nil (r-block (if (r-call == (r-call r-index (r-call class v) 1) "dlayoutn") (return (r-call as.numeric (r-call r-index (r-call class v) 2)))) (if (r-call ! (r-call is.null v)) (r-block (for i (r-call : (r-call length v) 1) (if (r-call > (r-call r-aref v i) 1) (return i)))) (r-block (return 1))) (return (r-call length v)))))) (<- is.scalar (lambda (x) (let nil (r-block (&& (|\|\|| (r-call == (r-call mode x) "numeric") (r-call == (r-call mode x) "complex")) (r-call is.null (r-call (r-call .Primitive "dim") x)) (r-call == (r-call length x) 1)))))) (<- p 1) (r-block (ref= #:g0 (r-call c "dlayout" "numeric")) (<- p (r-call class p #:g0)) #:g0) (<- darray (lambda (id shape distribution isreal) (let ((d nil) (distribution nil) (shape nil)) (r-block (<- shape (r-call as.array shape)) (<- distribution (r-call + distribution 1)) (r-block (ref= #:g1 (r-call append "dlayoutn" (r-call toString distribution) (r-call class shape))) (<- shape (r-call class shape #:g1)) #:g1) (<- d (r-call list (*named* id id) (*named* shape shape) (*named* isreal isreal) (*named* logical *r-false*) nil nil)) (r-block (<- d (r-call class d "darray")) "darray") d)))) (<- darraydist (lambda (da) (let nil (r-block (r-call as.numeric (r-call r-aref (r-call class (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2)))))) (<- is.darray (lambda (x) (let nil (r-block (r-call == (r-call r-index (r-call class x) 1) "darray"))))) (<- is.nd (lambda (x) (let nil (r-block (r-call != (r-call length (r-call dim x)) 2))))) (<- is.darraynd (lambda (x) (let nil (r-block (&& (r-call is.darray x) (r-call is.nd x)))))) (<- is.dlayout (lambda (x) (let nil (r-block (r-call any (r-call == (r-call class x) "dlayout")))))) (<- vdim (lambda (x) (let nil (r-block (if (r-call is.vector x) (r-call length x) (r-call dim x)))))) (<- |[[.dlayoutn| (<- |[.dlayoutn| (lambda (dl n) (let ((didi nil) (r nil) (dd nil)) (r-block (<- dd (r-call as.numeric (r-call r-aref (r-call class dl) 2))) (if (r-call == (r-call length n) 1) (r-block (if (r-call == n dd) (r-call * (r-call r-index (r-call as.vector dl) n) p) (r-call r-index (r-call as.vector dl) n))) (r-block (<- r (r-call r-index (r-call as.numeric dl) n)) (<- didi (r-call dimdis r)) (for i (r-call : 1 (r-call length n)) (r-block (if (r-call == (r-call r-aref n i) dd) (r-block (<- didi i) (break))))) (r-block (ref= #:g2 (r-call append "dlayoutn" (r-call toString didi) (r-call class r))) (<- r (r-call class r #:g2)) #:g2) (return r)))))))) (<- print.darray (lambda (d ...) (let ((shs nil) (sh nil)) (r-block (<- sh (r-call as.vector (r-call r-aref d (index-in-strlist shape (r-call attr d "names"))))) (<- shs (r-call deparse sh)) (if (r-call > (r-call length sh) 1) (r-block (<- shs (r-call substring shs 2))) (r-block (<- shs (r-call paste " (" shs ") " (*named* sep ""))))) (r-call print.default (r-call paste "<darray id:" (r-call r-aref d (index-in-strlist id (r-call attr d "names"))) " shape:" shs " distribution:" (r-call r-aref (r-call class (r-call r-aref d (index-in-strlist shape (r-call attr d "names")))) 2) ">" (*named* sep "")) (*named* quote *r-false*)) (r-call invisible d))))) (<- validdist (lambda (dims dd) (let nil (r-block (if (|\|\|| (r-call > dd (r-call length dims)) (r-call == (r-call r-aref dims dd) 1)) (return (r-call dimdis (r-call as.vector dims)))) (return dd))))) (<- dim.darray (lambda (x) (let nil (r-block (r-call r-aref x (index-in-strlist shape (r-call attr x "names"))))))) (<- dim<-.darray (lambda (x value) (let ((d nil) (dd nil)) (r-block (if (r-call == (r-call r-index (r-call class value) 1) "dlayoutn") (r-block (<- dd (r-call as.numeric (r-call r-index (r-call class value) 2)))) (<- dd (r-call darraydist x))) (<- dd (r-call validdist value dd)) (if (&& (r-call == (r-call length value) 2) (r-call == (r-call length (r-call r-aref x (index-in-strlist shape (r-call attr x "names")))) 2)) (r-block (r-call ppcommand "ppdense_reshape" x (r-call r-aref value 1) (r-call - dd 1))) (r-block (<- d (r-call ppcommand "ppdensend_reshape" x (r-call length value) (r-call as.real value) (r-call - dd 1))) (if (r-call == (r-call length (r-call r-aref d (index-in-strlist shape (r-call attr d "names")))) 2) (r-call ppcommand "ppdensend_clobber_singletons_and_demote" d)) d)))))) (<- length.darray (lambda (d) (let nil (r-block (r-call prod (r-call r-aref d (index-in-strlist shape (r-call attr d "names")))))))) (<- ppzeros (lambda (dims) (let nil (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_zeros" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims)) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "zeros")))))) (<- ppones (lambda (dims) (let nil (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_ones" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims) 1) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "ones")))))) (<- pprand (lambda (dims) (let nil (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_rand" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims)) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "rand")))))) (<- ppback (lambda (m dist allowScalar) (let ((d nil) (m nil) (lg nil) (allowScalar nil) (dist nil)) (r-block (when (missing dist) (<- dist (r-call dimdis (r-call dim m)))) (when (missing allowScalar) (<- allowScalar *r-false*)) (if (|\|\|| (r-call is.darray m) (r-call == (r-call length m) 0)) (return m)) (<- lg (r-call is.logical m)) (if (&& (r-call ! (r-call is.complex m)) (r-call ! (r-call is.real m))) (r-block (if (r-call is.vector m) (<- m (r-call as.real m)) (<- m (r-call dim<- (r-call as.real m) (r-call dim m)))))) (if (r-call is.scalar m) (r-block (if allowScalar (return (r-call ppcommand "ppdensend_ppback_scalar" m))) (return m))) (if (r-call ! (missing dist)) (<- dist (r-call validdist dist))) (if (&& (r-call ! (r-call is.vector m)) (r-call == (r-call length (r-call dim m)) 2)) (<- d (r-call ppcommand "pp_dense_ppback" m (r-call r-index (r-call dim m) 1) (r-call r-index (r-call dim m) 2) dist)) (<- d (r-call ppcommand "ppdensend_ppback" (r-call - dist 1) (r-call as.real (r-call vdim m)) (r-call is.real m) m))) (if lg (r-block (<- d (r-call r-aref d (index-in-strlist logical (r-call attr d "names")) *r-true*)) *r-true*)) d)))) (<- ppfront (lambda (da) (let ((m nil) (l nil)) (r-block (if (r-call ! (r-call is.darray da)) (return da)) (if (r-call == (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2) (r-block (<- l (r-call ppcommand "ppdense_ppfront" da)) (if (r-call r-aref da (index-in-strlist logical (r-call attr da "names"))) (<- m (r-call as.logical (r-call r-aref l 1))) (<- m (r-call r-aref l 1))) (r-block (ref= #:g3 (r-call c (r-call r-aref l 2) (r-call r-aref l 3))) (<- m (r-call dim m #:g3)) #:g3)) (r-block (<- m (r-call ppcommand "ppdensend_ppfront" da)) (if (r-call r-aref da (index-in-strlist logical (r-call attr da "names"))) (<- m (r-call as.logical m))) (r-block (ref= #:g4 (r-call as.vector (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))))) (<- m (r-call dim m #:g4)) #:g4))) m)))) (<- vector (lambda (mode length) (let ((length nil) (mode nil)) (r-block (when (missing mode) (<- mode "logical")) (when (missing length) (<- length 0)) (r-call UseMethod "vector" length))))) (<- vector.default (r-call .Primitive "vector")) (<- vector.dlayout (lambda (mode length) (let ((d nil) (length nil) (mode nil)) (r-block (when (missing mode) (<- mode "logical")) (when (missing length) (<- length 0)) (<- d (r-call ppzeros (r-call c 1 length))) (if (r-call == mode "logical") (r-block (<- d (r-call r-aref d (index-in-strlist logical (r-call attr d "names")) *r-true*)) *r-true*)) d)))) (<- double (lambda (length) (let ((length nil)) (r-block (when (missing length) (<- length 0)) (r-call vector "double" length))))) (<- logical (lambda (length) (let ((length nil)) (r-block (when (missing length) (<- length 0)) (r-call vector "logical" length))))) (<- c (lambda (...) (let ((l nil) (v nil) (args nil)) (r-block (<- args (r-call list r-dotdotdot)) (<- v (r-call (r-call .Primitive "c") r-dotdotdot)) (<- l (r-call length args)) (if (r-call == l 0) (return v)) (for i (r-call : 1 l) (if (r-call is.dlayout (r-call r-aref args i)) (r-block (r-block (ref= #:g5 (r-call append "dlayoutn" (r-call toString i) (r-call class v))) (<- v (r-call class v #:g5)) #:g5) (return v)))) v)))) (<- rep (lambda (x times length.out each) (let ((out nil) (x nil) (each nil) (length.out nil) (times nil)) (r-block (when (missing times) (<- times 1)) (when (missing length.out) (<- length.out NA)) (when (missing each) (<- each 1)) (if (r-call is.darray x) (r-block (r-block (ref= #:g6 (r-call c 1 (r-call length x))) (<- x (r-call dim x #:g6)) #:g6) (if (|\|\|| (&& (missing length.out) (r-call > (r-call length times) 1)) (r-call > each 1)) (<- x (r-call ppfront x)))) (if (r-call ! (|\|\|| (r-call is.dlayout times) (&& (r-call ! (missing length.out)) (r-call is.dlayout length.out)))) (r-block (return (r-call (r-call .Primitive "rep") x (*named* times times) (*named* length.out length.out) (*named* each each)))))) (if (r-call > each 1) (r-block (<- x (r-call (r-call .Primitive "rep") x (*named* each each))))) (if (missing length.out) (r-block (if (r-call > (r-call length times) 1) (r-block (<- x (r-call (r-call .Primitive "rep") x (*named* times times))) (<- times 1)))) (r-block (<- times (r-call ceiling (r-call / length.out (r-call length x)))))) (if (r-call == (r-call length x) 1) (r-block (return (r-call * (r-call ppones (r-call r-aref times 1)) (r-call r-aref x 1))))) (<- x (r-call ppback (r-call as.2d x))) (<- out (r-call ppcommand "ppdense_repmat" x 1 (r-call r-aref times 1) 1)) (if (&& (r-call ! (missing length.out)) (r-call != (r-call r-aref (r-call dim out) 2) length.out)) (r-block (<- out (r-call ppcommand "ppdense_subsref_col" out (r-call as.realarray (r-call : 1 length.out)))))) (r-block (ref= #:g7 (r-call length out)) (<- out (r-call dim out #:g7)) #:g7) (return out))))) (<- globalbinding (lambda (sym) (let nil (r-block (r-call eval (r-call as.name sym) (*named* envir (r-call globalenv))))))) (<- boundp (lambda (sym) (let nil (r-block (return (r-call != (r-call class (r-call try (r-call globalbinding sym) (*named* silent *r-true*))) "try-error")))))) (<- redefining (lambda (sym) (let ((rname nil) (name nil)) (r-block (<- name (r-call deparse (substitute sym))) (<- rname (r-call paste "R" name (*named* sep ""))) (if (r-call ! (r-call boundp rname)) (r-call assign rname (r-call globalbinding name) (*named* envir (r-call globalenv)))))))) (r-call redefining array) (<- array (lambda (data dim dimnames) (let ((dd nil) (dimnames nil) (dim nil) (data nil)) (r-block (when (missing data) (<- data NA)) (when (missing dim) (<- dim (r-call length data))) (when (missing dimnames) (<- dimnames nil)) (<- dd *r-false*) (if (r-call == (r-call r-index (r-call class dim) 1) "dlayoutn") (<- dd (r-call as.numeric (r-call r-index (r-call class dim) 2)))) (if (r-call is.darray data) (r-block (if (r-call != (r-call length data) (r-call prod dim)) (r-block (<- data (r-call rep data (*named* length.out (r-call prod dim)))))) (if (r-call all (r-call == dim (r-call as.vector (r-call r-aref data (index-in-strlist shape (r-call attr data "names")))))) (return data)) (return (r-call dim<-.darray data dim))) (r-block (if dd (r-block (<- data (r-call rep data (*named* length.out (r-call * (r-call prod dim) p)))) (return (r-call dim<-.darray data dim))) (r-block (r-call Rarray data dim dimnames))))))))) (r-call redefining matrix) (<- matrix (lambda (data nrow ncol byrow dimnames) (let ((m nil) (l nil) (dimnames nil) (byrow nil) (ncol nil) (nrow nil) (data nil)) (r-block (when (missing data) (<- data NA)) (when (missing nrow) (<- nrow 1)) (when (missing ncol) (<- ncol 1)) (when (missing byrow) (<- byrow *r-false*)) (when (missing dimnames) (<- dimnames nil)) (<- l (r-call length data)) (if (missing nrow) (r-block (if (r-call ! (missing ncol)) (<- nrow (r-call / l ncol)) (r-block (<- nrow l) (<- ncol 1)))) (if (missing ncol) (<- ncol (r-call / l nrow)))) (<- m (r-call array data (r-call c nrow ncol) dimnames)) (if byrow (r-call t m) m))))) (<- t.darray (lambda (da) (let nil (r-block (if (|\|\|| (r-call == (r-call darraydist da) 1) (r-call == (r-call darraydist da) 2)) (r-call ppcommand "ppdense_transpose" da 0) (r-call ppcommand "pppblas_trans" da)))))) (<- runif (lambda (n min max) (let ((max nil) (min nil)) (r-block (when (missing min) (<- min 0)) (when (missing max) (<- max 1)) (if (r-call is.dlayout n) (r-call pprand n) (r-call .Internal (r-call runif n min max))))))) (r-call redefining diag) (<- diag (lambda (da nrow ncol) (let ((da nil) (ncol nil)) (r-block (when (missing ncol) (<- ncol n)) (if (r-call is.darray da) (r-block (if (r-call == (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 1) (r-block (<- da (r-call as.2d da)))) (if (r-call == (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2) (r-block (if (r-call == (r-call r-index (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))) 1) 1) (return (r-call ppcommand "ppdense_diagv" da 0)) (if (r-call == (r-call r-index (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))) 2) 1) (return (r-call ppcommand "ppdense_diagv" (r-call t da) 0)))))) (r-call t (r-call ppcommand "ppdense_diag" da 0))) (r-call Rdiag da)))))) (<- dbinaryop (lambda (code scalarcode bscalarcode ndcode a b) (let ((b nil) (a nil)) (r-block (if (r-call is.scalar a) (r-block (if (r-call is.nd b) (r-call ppcommand "ppdensend_s_binary_operator" a b ndcode *r-true*) (r-call ppcommand "ppdense_scalar_op" scalarcode a b))) (if (r-call is.scalar b) (r-block (if (r-call is.nd a) (r-call ppcommand "ppdensend_binary_operator_s" a b ndcode *r-true*) (r-call ppcommand "ppdense_scalar_op" bscalarcode b a))) (r-block (if (r-call ! (r-call is.darray a)) (<- a (r-call ppback a))) (if (r-call ! (r-call is.darray b)) (<- b (r-call ppback b))) (if (|\|\|| (r-call is.nd a) (r-call is.nd b)) (r-call ppcommand "ppdensend_binary_operator" a b ndcode *r-true*) (r-call ppcommand "ppdense_binary_op" code a b))))))))) (<- +.darray (lambda (a b) (let nil (r-block (r-call dbinaryop 1 1 1 2 a b))))) (<- *.darray (lambda (a b) (let nil (r-block (r-call dbinaryop 3 3 3 3 a b))))) (<- /.darray (lambda (a b) (let nil (r-block (r-call dbinaryop 4 4 5 6 a b))))) (<- ^.darray (lambda (a b) (let nil (r-block (r-call dbinaryop 7 10 11 19 a b))))) (<- mkdlogicalop (lambda (c sc bsc ndcode) (let nil (r-block (lambda (a b) (let ((da nil)) (r-block (<- da (r-call dbinaryop c sc bsc ndcode a b)) (r-block (<- da (r-call r-aref da (index-in-strlist logical (r-call attr da "names")) *r-true*)) *r-true*) da))))))) (<- <.darray (r-call mkdlogicalop 14 16 17 15)) (<- >.darray (r-call mkdlogicalop 15 17 16 17)) (<- ==.darray (r-call mkdlogicalop 18 20 20 13)) (<- !=.darray (r-call mkdlogicalop 19 21 21 14)) (<- <=.darray (r-call mkdlogicalop 16 18 19 18)) (<- >=.darray (r-call mkdlogicalop 17 19 18 16)) (<- &.darray (lambda (a b) (let ((da nil) (a nil) (other nil)) (r-block (if (r-call is.darray a) (<- other b) (r-block (<- other a) (<- a b))) (if (r-call is.scalar other) (r-block (if other (return (r-call ppcopy a)) (return (r-call ppzeros (r-call dim a)))))) (<- da (r-call dbinaryop 11 (r-call - 1) (r-call - 1) 9 a b)) (r-block (<- da (r-call r-aref da (index-in-strlist logical (r-call attr da "names")) *r-true*)) *r-true*) da)))) (<- |\|.darray| (lambda (a b) (let ((da nil) (a nil) (other nil)) (r-block (if (r-call is.darray a) (<- other b) (r-block (<- other a) (<- a b))) (if (r-call is.scalar other) (r-block (if other (return (r-call ppones (r-call dim a))) (return (r-call ppcopy a))))) (<- da (r-call dbinaryop 12 (r-call - 1) (r-call - 1) 10 a b)) (r-block (<- da (r-call r-aref da (index-in-strlist logical (r-call attr da "names")) *r-true*)) *r-true*) da)))) (<- !.darray (lambda (a) (let ((da nil)) (r-block (if (r-call is.nd a) (r-block (<- da (r-call ppcommand "ppdensend_not" a))) (r-block (<- da (r-call ppcommand "ppdense_unary_op" 2 a)))) (r-block (<- da (r-call r-aref da (index-in-strlist logical (r-call attr da "names")) *r-true*)) *r-true*) da)))) (<- %*% (lambda (a b) (let nil (r-block (if (r-call is.darray a) (r-block (if (r-call is.darray b) (r-block (r-call ppcommand "pppblas_gemm" a b)) (r-block (r-call ppcommand "pppblas_gemm" a (r-call ppback b))))) (if (r-call is.darray b) (r-block (r-call ppcommand "pppblas_gemm" (r-call ppback a) b)) (r-call (r-call .Primitive "%*%") a b))))))) (<- -.darray (lambda (a b) (let ((a nil) (b nil)) (r-block (if (missing b) (if (r-call is.nd a) (r-block (<- b a) (<- a 0)) (r-block (return (r-call ppcommand "ppdense_unary_op" 13 a))))) (if (r-call is.scalar b) (r-call dbinaryop 1 1 1 4 (r-call - b) a) (r-call dbinaryop 2 2 2 4 a b)))))) (<- ppreduce (lambda (da axis allfunc axisfunc ndcode islogical) (let ((axis nil) (da nil) (res nil) (nd nil) (islogical nil)) (r-block (when (missing islogical) (<- islogical *r-false*)) (<- nd (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))))) (if (r-call == nd 2) (r-block (if (r-call ! axis) (r-call ppcommand allfunc da) (r-block (<- res (r-call ppcommand axisfunc da axis)) (if (r-call is.list res) (<- res (r-call r-aref res 1))) (return res)))) (r-block (if (r-call ! axis) (r-block (r-block (ref= #:g8 (r-call length da)) (<- da (r-call dim da #:g8)) #:g8) (<- axis 1))) (<- res (r-call ppcommand "ppdensend_reduce" da ndcode (r-call - axis 1))) (if (&& islogical (r-call is.darray res)) (r-block (<- res (r-call r-aref res (index-in-strlist logical (r-call attr res "names")) *r-true*)) *r-true*)) (return res))))))) (<- any.darray (lambda (da axis na.rm) (let ((res nil) (na.rm nil) (axis nil)) (r-block (when (missing axis) (<- axis *r-false*)) (when (missing na.rm) (<- na.rm *r-false*)) (if (r-call == (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2) (r-block (if (r-call ! axis) (r-block (return (r-call > (r-call ppcommand "ppbase_nnz" da) 0))) (r-block (if (r-call == (r-call r-index (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_any" da axis)) (r-block (<- res (r-call r-aref res (index-in-strlist logical (r-call attr res "names")) *r-true*)) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 5 *r-true*))))))) (<- all.darray (lambda (da axis na.rm) (let ((res nil) (na.rm nil) (axis nil)) (r-block (when (missing axis) (<- axis *r-false*)) (when (missing na.rm) (<- na.rm *r-false*)) (if (r-call == (r-call length (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2) (r-block (if (r-call ! axis) (r-block (return (r-call == (r-call ppcommand "ppbase_nnz" da) (r-call length da)))) (r-block (if (r-call == (r-call r-index (r-call r-aref da (index-in-strlist shape (r-call attr da "names"))) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_all" da axis)) (r-block (<- res (r-call r-aref res (index-in-strlist logical (r-call attr res "names")) *r-true*)) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 6 *r-true*))))))) (<- sum (lambda (... na.rm axis) (let ((da nil) (l nil) (axis nil) (na.rm nil)) (r-block (when (missing na.rm) (<- na.rm *r-false*)) (when (missing axis) (<- axis *r-false*)) (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return 0)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_sumv" "ppdense_sum" 2) (r-call (r-call .Primitive "sum") r-dotdotdot (*named* na.rm na.rm))))))) (<- prod (lambda (... na.rm axis) (let ((da nil) (l nil) (axis nil) (na.rm nil)) (r-block (when (missing na.rm) (<- na.rm *r-false*)) (when (missing axis) (<- axis *r-false*)) (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return 1)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_prodv" "ppdense_prod" 3) (r-call (r-call .Primitive "prod") r-dotdotdot (*named* na.rm na.rm))))))) (<- min (lambda (... na.rm axis) (let ((da nil) (l nil) (axis nil) (na.rm nil)) (r-block (when (missing na.rm) (<- na.rm *r-false*)) (when (missing axis) (<- axis *r-false*)) (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return Inf)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_minv" "ppdense_min" 8) (r-call (r-call .Primitive "min") r-dotdotdot (*named* na.rm na.rm))))))) (<- max (lambda (... na.rm axis) (let ((da nil) (l nil) (axis nil) (na.rm nil)) (r-block (when (missing na.rm) (<- na.rm *r-false*)) (when (missing axis) (<- axis *r-false*)) (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return (r-call - Inf))) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_maxv" "ppdense_max" 7) (r-call (r-call .Primitive "max") r-dotdotdot (*named* na.rm na.rm))))))) (<- ppcopy (lambda (d dist) (let ((dist nil)) (r-block (when (missing dist) (<- dist 2)) (if (|\|\|| (missing dist) (r-call == dist (r-call darraydist d))) (return (r-call ppcommand "ppbase_createMatrixCopy" d)) (return (r-call ppcommand "ppbase_createMatrixCopyRedist" d dist))))))) (<- as.realarray (lambda (x) (let nil (r-block (r-call as.array (r-call as.real x)))))) (<- as.1d (lambda (x) (let ((x nil)) (r-block (r-block (ref= #:g9 (r-call length x)) (<- x (r-call dim x #:g9)) #:g9) (return x))))) (<- as.2d (lambda (x) (let ((x nil)) (r-block (r-block (ref= #:g100 (r-call c 1 (r-call length x))) (<- x (r-call dim x #:g100)) #:g100) (return x))))) (<- as.real2d (lambda (x) (let ((x nil)) (r-block (<- x (r-call as.real x)) (r-block (ref= #:g101 (r-call c 1 (r-call length x))) (<- x (r-call dim x #:g101)) #:g101) (return x))))) (<- toIndexVec2d (lambda (i con) (let nil (r-block (if (r-call == (r-call length i) 0) (r-block (return (r-call ppcommand "ppdense_zeros" 1 0 1)))) (return (r-call ppback (r-call as.2d i) (*named* allowScalar *r-true*))))))) (<- toIndexVec (lambda (i con) (let nil (r-block (if (r-call == (r-call length i) 0) (r-block (return (r-call ppcommand "ppdensend_add" 0 0 1 "zeros")))) (return (r-call ppback i (*named* allowScalar *r-true*))))))) (<- toNumIndex (lambda (i) (let ((i nil) (N nil)) (r-block (if (r-call ! (r-call is.darray i)) (r-block (if (r-call is.logical i) (r-block (<- N (r-call : 1 (r-call length i))) (<- i (r-call r-index N i)))) (return i)) (if (r-call ! (r-call r-aref i (index-in-strlist logical (r-call attr i "names")))) (r-block (return i)))) (if (r-call != (r-call length (r-call dim i)) 2) (r-block (ref= #:g102 (r-call c 1 (r-call length i))) (<- i (r-call dim i #:g102)) #:g102)) (<- i (r-call r-aref (r-call ppcommand "ppdense_find" i 1 0 0) 1)) (r-block (ref= #:g103 (r-call length i)) (<- i (r-call dim i #:g103)) #:g103) i)))) (<- expandLinearIndex (lambda (shape i) (let ((i nil) (out nil)) (r-block (<- out (r-call numeric (r-call length shape))) (for n (r-call : 1 (r-call length shape)) (r-block (r-block (ref= #:g104 (r-call + (r-call %% (r-call - i 1) (r-call r-index shape n)) 1)) (<- out (r-call r-aref out n #:g104)) #:g104) (<- i (r-call + (r-call %/% (r-call - i 1) (r-call r-index shape n)) 1)))) out)))) (<- toLinearIndex (lambda (shape iv) (let nil (r-block (r-call + (r-call sum (r-call * (r-call - iv 1) (r-call cumprod (r-call r-index (r-call c 1 shape) (r-call - (r-call - (r-call length shape)) 1))))) 1))))) (<- toLinearIndexes (lambda (shape im) (let ((ds nil)) (r-block (<- ds (r-call t (r-call array (r-call cumprod (r-call r-index (r-call c 1 shape) (r-call - (r-call - (r-call length shape)) 1))) (r-call rev (r-call dim im))))) (r-call as.1d (r-call + (r-call apply (r-call * (r-call - im 1) ds) 1 sum) 1)))))) (<- starpcolon (quote :missingarg:)) (<- is.colon (lambda (x) (let nil (r-block (r-call identical x starpcolon))))) (<- normalizeIndexes (lambda (shape idxs) (let ((where nil) (nonz nil) (lg nil) (i nil) (out nil) (li nil)) (r-block (<- li (r-call length idxs)) (<- out (r-call vector "list" li)) (if (r-call == li 0) (return out) (if (&& (r-call > li 1) (r-call != li (r-call length shape))) (r-call stop "wrong number of subscripts"))) (for n (r-call : 1 li) (r-block (<- i (r-call r-aref idxs n)) (if (r-call == (r-call length (r-call dim i)) 2) (r-block (<- i (r-call toLinearIndexes shape i)) (if (r-call == (r-call length i) 1) (<- i (r-call as.real (r-call as.vector (r-call ppfront i)))))) (if (r-call ! (r-call is.colon i)) (r-block (if (r-call > (r-call length (r-call dim i)) 2) (r-block (<- i (r-call as.1d i)))) (<- lg (|\|\|| (r-call is.logical i) (&& (r-call is.darray i) (r-call r-aref i (index-in-strlist logical (r-call attr i "names")))))) (if (&& lg (r-call == li 1)) (<- i (r-call rep i (*named* length.out (r-call prod shape))))) (<- i (r-call toNumIndex i)) (if (r-call ! lg) (r-block (<- nonz (r-call != i 0)) (if (r-call ! (r-call is.darray nonz)) (r-block (<- i (r-call r-index i nonz))) (r-block (<- where (r-call r-aref (r-call ppcommand "ppdense_find" (r-call as.2d i) 1 0 0) 1)) (<- i (r-call ppcommand "ppdense_subsref_dcol" i where)))))) (if (r-call == (r-call length i) 1) (<- i (r-call as.real (r-call as.vector (r-call ppfront i))))) (if (&& (r-call is.scalar i) (r-call < i 0)) (r-block (<- i (r-call r-index (r-call : 1 (r-call r-index shape n)) i))))))) (r-block (<- out (r-call r-aref out n i)) i))) out)))) (<- indexSizes (lambda (d idxs) (let ((lens nil) (whichcolons nil) (n nil)) (r-block (<- n (r-call length idxs)) (<- whichcolons (r-call logical n)) (<- lens (r-call numeric n)) (for i (r-call : 1 n) (r-block (if (r-call is.colon (r-call r-aref idxs i)) (r-block (r-block (<- whichcolons (r-call r-index whichcolons i *r-true*)) *r-true*) (r-block (ref= #:g105 (r-call r-index (r-call dim d) i)) (<- lens (r-call r-index lens i #:g105)) #:g105)) (r-block (ref= #:g10 (r-call length (r-call r-aref idxs i))) (<- lens (r-call r-index lens i #:g10)) #:g10)))) (r-call list lens whichcolons))))) (<- |[.darray| (lambda (d ...) (let ((al nil) (result nil) (slicepos nil) (slice nil) (a nil) (c nil) (r nil) (x nil) (whichcolons nil) (lens nil) (tmp nil) (idxs nil) (n nil)) (r-block (<- n (r-call nargs)) (if (r-call == n 1) (return d)) (<- idxs (r-call normalizeIndexes (r-call dim d) (r-call revealargs (r-call get "...")))) (<- tmp (r-call indexSizes d idxs)) (<- lens (r-call r-aref tmp 1)) (<- whichcolons (r-call r-aref tmp 2)) (if (r-call == (r-call prod lens) 0) (r-block (return (r-call array 0 (r-call r-index lens (r-call != lens 1)))))) (if (r-call all whichcolons) (return (r-call ppcopy d))) (if (r-call == n 2) (r-block (if (r-call == (r-call length (r-call dim d)) 2) (<- x (r-call ppcommand "ppdense_subsref_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))))) (<- x (r-call ppcommand "ppdensend_subsref_idx_dist" d (r-call ppback (r-call r-aref idxs 1) (*named* allowScalar *r-true*))))) (if (r-call == (r-call length (r-call r-aref idxs 1)) 1) (return (r-call ppfront x)) (return x))) (if (r-call == n 3) (r-block (<- r (r-call r-aref idxs 1)) (<- c (r-call r-aref idxs 2)) (if (&& (r-call is.scalar r) (r-call is.scalar c)) (r-block (return (r-call ppcommand "ppdense_viewelement" d r c)))) (if (r-call is.colon r) (r-block (if (r-call is.darray c) (<- a (r-call ppcommand "ppdense_subsref_dcol" d c)) (<- a (r-call ppcommand "ppdense_subsref_col" d (r-call as.realarray c))))) (if (r-call is.colon c) (r-block (if (r-call is.darray r) (<- a (r-call ppcommand "ppdense_subsref_drow" d r)) (<- a (r-call ppcommand "ppdense_subsref_row" d (r-call as.realarray r))))) (r-block (if (r-call ! (r-call is.darray r)) (<- r (r-call as.realarray r))) (if (r-call ! (r-call is.darray c)) (<- c (r-call as.realarray c))) (<- a (r-call ppcommand "ppdense_subsref_rowcol" d r c))))) (if (r-call == (r-call sum (r-call > lens 1)) 1) (return (r-call as.1d a))) (return a)))) (if (r-call all (r-call lapply idxs is.scalar)) (r-block (return (r-call ppcommand "ppdensend_subsref_scalar" d (r-call as.numeric idxs))))) (if (r-call == (r-call sum whichcolons) (r-call - (r-call length (r-call dim d)) 1)) (r-block (<- slice (r-call as.realarray (r-call r-aref (r-call r-index idxs (r-call ! whichcolons)) 1))) (<- slicepos (r-call r-index (r-call : 1 (r-call length idxs)) (r-call ! whichcolons))) (if (r-call == slicepos (r-call darraydist d)) (r-block (if (r-call > (r-call length slice) 1) (r-block (r-block (ref= #:g11 (r-call c (r-call length slice) 1)) (<- slice (r-call dim slice #:g11)) #:g11) (<- slice (r-call ppback slice)))) (<- result (r-call ppcommand "ppdensend_subsref_extract_slices_dist" d slice))) (r-block (<- result (r-call ppcommand "ppdensend_subsref_extract_slices_local" d (r-call - slicepos 1) slice))))) (r-block (<- idxs (r-call lapply idxs (lambda (i) (let nil (r-block (if (r-call is.colon i) (r-call - 1) (r-call as.realarray i))))))) (<- al (r-call append "ppdensend_subsref_element_list" (r-call append 0 idxs))) (r-block (<- al (r-call r-aref al 2 d)) d) (<- result (r-call ppvcommand al)) (if (r-call == (r-call sum (r-call > lens 1)) 1) (return (r-call as.1d result))))) (return result))))) (<- |[<-.darray| (lambda (d ...) (let ((al nil) (slicepos nil) (slice nil) (c nil) (r nil) (whichcolons nil) (lens nil) (tmp nil) (idxs nil) (rhs nil) (arglist nil) (n nil)) (r-block (<- n (r-call nargs)) (<- arglist (r-call revealargs (r-call get "..."))) (<- rhs (r-call r-aref arglist (r-call - n 1))) (<- idxs (r-call normalizeIndexes (r-call dim d) (r-call r-index arglist (r-call + (r-call - n) 1)))) (if (&& (r-call == (r-call length idxs) 1) (r-call is.colon (r-call r-aref idxs 1))) (r-block (<- idxs (r-call rep (r-call list starpcolon) (*named* length.out (r-call length (r-call dim d))))) (<- n (r-call + 2 (r-call length (r-call dim d)))))) (<- tmp (r-call indexSizes d idxs)) (<- lens (r-call r-aref tmp 1)) (<- whichcolons (r-call r-aref tmp 2)) (if (r-call == (r-call prod lens) 0) (r-block (return d))) (if (r-call ! (r-call is.scalar rhs)) (r-block (if (&& (r-call != (r-call length rhs) (r-call prod lens)) (r-call > (r-call prod lens) 1)) (r-block (<- rhs (r-call rep rhs (*named* length.out (r-call prod lens)))))) (if (r-call is.darray rhs) (r-block (if (r-call == (r-call length (r-call dim rhs)) 1) (<- rhs (r-call as.2d rhs)))) (r-block (<- rhs (r-call as.array rhs)) (if (r-call == (r-call length (r-call dim rhs)) 1) (<- rhs (r-call as.2d rhs))) (<- rhs (r-call ppback rhs)))))) (if (r-call == (r-call length (r-call dim d)) 2) (r-block (if (r-call all whichcolons) (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_setall" d rhs) (r-call ppcommand "ppdense_copyall" rhs d)) (if (r-call == n 3) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_idx_s" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) rhs) (r-call ppcommand "ppdense_subsasgn_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) (r-call ppback rhs)))) (r-block (<- r (r-call r-aref idxs 1)) (<- c (r-call r-aref idxs 2)) (if (&& (r-call is.scalar r) (r-call is.scalar c)) (r-block (if (r-call ! (r-call is.scalar rhs)) (r-call stop "expected scalar value")) (r-call ppcommand "ppdense_setelement" d r c rhs)) (if (r-call is.colon r) (r-block (if (r-call is.darray c) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_dcol_s" d c rhs) (r-call ppcommand "ppdense_subsasgn_dcol" d c rhs))) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_col_s" d (r-call as.real2d c) rhs) (r-call ppcommand "ppdense_subsasgn_col" d (r-call as.real2d c) rhs))))) (if (r-call is.colon c) (r-block (if (r-call is.darray r) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_drow_s" d r rhs) (r-call ppcommand "ppdense_subsasgn_drow" d r rhs))) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_row_s" d (r-call as.real2d r) rhs) (r-call ppcommand "ppdense_subsasgn_row" d (r-call as.real2d r) rhs))))) (r-block (if (r-call ! (r-call is.darray r)) (<- r (r-call as.realarray r))) (if (r-call ! (r-call is.darray c)) (<- c (r-call as.realarray c))) (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_rowcol_s" d r c rhs) (r-call ppcommand "ppdense_subsasgn_rowcol" d r c rhs))))))))) (return d)) (r-block (if (r-call == n 3) (r-call ppcommand "ppdensend_subsasgn_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) rhs) (if (r-call all (r-call lapply idxs is.scalar)) (r-block (r-call ppcommand "ppdensend_subsasgn_scalar" d (r-call as.numeric idxs) rhs)) (if (r-call == (r-call sum whichcolons) (r-call - (r-call length (r-call dim d)) 1)) (r-block (<- slice (r-call as.realarray (r-call r-aref (r-call r-index idxs (r-call ! whichcolons)) 1))) (<- slicepos (r-call r-index (r-call : 1 (r-call length idxs)) (r-call ! whichcolons))) (r-call ppcommand "ppdensend_subsasgn_slice" d (r-call - slicepos 1) slice rhs)) (r-block (<- idxs (r-call lapply idxs (lambda (i) (let nil (r-block (if (r-call is.colon i) (r-call - 1) (r-call as.realarray i))))))) (<- al (r-call append "ppdensend_subsasgn_tuple" (r-call append 0 (r-call append idxs 0)))) (r-block (<- al (r-call r-aref al 2 d)) d) (r-block (<- al (r-call r-aref al (r-call length al) rhs)) rhs) (r-call ppvcommand al))))))) d)))) (<- unaryops (r-call list (r-call list "ceiling" 9 "ceil") (r-call list "round" 10) (r-call list "floor" 11) (r-call list "sign" 14) (r-call list "abs" 15) (r-call list "sqrt" 16 *r-false*) (r-call list "exp" 17) (r-call list "log10" 19) (r-call list "log2" 20) (r-call list "Conj" 8 *r-false*) (r-call list "sin" 21) (r-call list "cos" 22) (r-call list "tan" 23))) (<- mkunaryop (lambda (code oldf ndname) (let ((ndname nil)) (r-block (r-call force code) (r-call force oldf) (if (r-call is.character ndname) (r-block (<- ndname (r-call paste "ppdensend_" ndname (*named* sep ""))) (lambda (x) (let nil (r-block (if (r-call is.darray x) (r-block (if (r-call == (r-call length (r-call r-aref x (index-in-strlist shape (r-call attr x "names")))) 2) (r-call ppcommand "ppdense_unary_op" code x) (r-call ppcommand ndname x))) (r-call oldf x)))))) (r-block (lambda (x) (let nil (r-block (if (r-call is.darray x) (r-call ppcommand "ppdense_unary_op" code x) (r-call oldf x))))))))))) (for i unaryops (r-block (<- ppname (r-call as.name (r-call r-aref i 1))) (<- Rf (r-call eval ppname)) (if (r-call == (r-call length i) 2) (<- ndn (r-call r-aref i 1)) (<- ndn (r-call r-aref i 3))) (r-call assign (r-call as.character ppname) (r-call mkunaryop (r-call r-aref i 2) Rf ndn) (*named* envir (r-call globalenv))))) (r-call redefining chol) (<- chol (lambda (m) (let ((l nil)) (r-block (if (r-call is.darray m) (r-block (<- l (r-call ppcommand "ppscalapack_chol" m)) (if (r-call > (r-call r-aref l 1) 0) (r-call stop "chol: not positive definite.")) (return (r-call r-aref l 2)))) (r-call Rchol m))))) (r-call redefining ginv) (<- ginv (lambda (m) (let ((l nil)) (r-block (if (r-call is.darray m) (r-block (<- l (r-call ppcommand "ppscalapack_inv" m)) (return (r-call r-aref l 1)))) (r-call Rginv m))))) (r-call redefining eigen) (<- eigen (lambda (x symmetric only.values EISPACK) (let ((out nil) (res nil) (vl nil) (EISPACK nil) (only.values nil)) (r-block (when (missing only.values) (<- only.values *r-false*)) (when (missing EISPACK) (<- EISPACK *r-false*)) (if (r-call ! (r-call is.darray x)) (return (r-call Reigen x symmetric only.values EISPACK))) (if only.values (<- vl 0) (<- vl 1)) (if (&& (r-call ! (missing symmetric)) symmetric) (r-block (<- res (r-call ppcommand "ppscalapack_eig_sym" x vl))) (r-block (<- res (r-call ppcommand "ppscalapack_eig" x vl)))) (<- out (r-call list (*named* values nil) (*named* vectors nil))) (if only.values (r-block (r-block (ref= #:g12 (r-call t res)) (<- out (r-call r-aref out (index-in-strlist values (r-call attr out "names")) #:g12)) #:g12)) (r-block (if (&& (r-call ! (missing symmetric)) symmetric) (r-block (r-block (ref= #:g13 (r-call t (r-call r-aref res 2))) (<- out (r-call r-aref out (index-in-strlist values (r-call attr out "names")) #:g13)) #:g13)) (r-block (r-block (ref= #:g14 (r-call diag (r-call r-aref res 2))) (<- out (r-call r-aref out (index-in-strlist values (r-call attr out "names")) #:g14)) #:g14))) (r-block (ref= #:g15 (r-call r-aref res 1)) (<- out (r-call r-aref out (index-in-strlist vectors (r-call attr out "names")) #:g15)) #:g15))) out)))) (r-call redefining apply) (<- apply (lambda (d axis f) (let ((axis nil)) (r-block (if (r-call ! (r-call is.darray d)) (return (r-call Rapply d axis f))) (<- axis (r-call + axis 1)) (if (r-call identical f sum) (r-call t (r-call ppcommand "ppdense_sum" d axis)) (r-call stop "starp: unsupported operation")))))) (r-call redefining diag<-) (<- diag<- (lambda (d value) (let ((idxs nil) (n nil) (value nil)) (r-block (if (r-call ! (r-call is.darray d)) (r-block (if (r-call is.darray value) (<- value (r-call ppfront value))) (return (r-call Rdiag<- d value)))) (if (r-call != (r-call length (r-call dim d)) 2) (r-call stop "starp diag<-: only supported for 2d")) (<- n (r-call min (r-call dim d))) (<- idxs (r-call ppcommand "ppdense_makeRange" 1 (r-call + (r-call r-index (r-call dim d) 1) 1) (r-call + (r-call * (r-call - n 1) (r-call r-index (r-call dim d) 1)) n))) (if (r-call is.scalar value) (r-block (r-call ppcommand "ppdense_subsasgn_idx_s" d idxs value)) (if (r-call != (r-call length value) n) (r-block (r-call stop "diag<-: replacement diagonal has wrong length")) (r-block (r-call ppcommand "ppdense_subsasgn_idx" d idxs (r-call ppback (r-call as.2d value)))))) d)))) (<- engineArg (lambda (arg) (let ((arg nil)) (r-block (<- arg (r-call tolower arg)) (if (r-call != arg "") (r-block (if (r-call != arg "c") (r-call stop "unknown engine specified")))) (return arg))))) (<- pploadcenginemodule (lambda (filename name) (let ((res nil) (name nil)) (r-block (when (missing name) (<- name "")) (<- res (r-call ppcommand "ppemode2_evaluate" "c" "ppevalc_builtin:load_module" 1 0 filename name)) (return (r-call r-aref (r-call ppcommand "ppemode2_getelement" (r-call r-index (r-call r-aref res 1) 1) 0) 2)))))) (<- ppunloadcenginemodule (lambda (name) (let nil (r-block (r-call ppcommand "ppemode2_evaluate" "c" "ppevalc_builtin:remove_module" 1 0 name) *r-true*)))) (<- pploadpackage (lambda (filename name engine) (let ((out nil) (engine nil) (name nil)) (r-block (when (missing name) (<- name "")) (when (missing engine) (<- engine "")) (<- engine (r-call engineArg engine)) (if (r-call == engine "c") (r-call pploadcenginemodule filename (*named* name name)) (r-block (<- out (r-call ppcommand "ppbase_loadUserPackage" filename name)) (if (r-call > (r-call length out) 1) (r-block (r-call warning (r-call r-index out 2)) (return (r-call r-index out 1)))) (return out))))))) (<- ppunloadpackage (lambda (name engine) (let ((engine nil)) (r-block (when (missing engine) (<- engine "")) (<- engine (r-call engineArg engine)) (if (r-call == engine "c") (r-call ppunloadcenginemodule name) (r-call ppcommand "ppbase_removeUserPackage" name)) *r-true*)))))
|