diff --git a/femtolisp/ast/asttools.scm b/femtolisp/ast/asttools.scm deleted file mode 100644 index f18ab5c..0000000 --- a/femtolisp/ast/asttools.scm +++ /dev/null @@ -1,88 +0,0 @@ -; utilities for AST processing - -(define (symconcat s1 s2) - (string->symbol (string-append (symbol->string s1) - (symbol->string s2)))) - -(define (list-adjoin item lst) - (if (memq item lst) - lst - (cons item lst))) - -(define (index-of item lst start) - (cond ((null? lst) #f) - ((eq? item (car lst)) start) - (else (index-of item (cdr lst) (+ start 1))))) - -(define (map! f l) - (define (map!- f l start) - (if (pair? l) - (begin (set-car! l (f (car l))) - (map!- f (cdr l) start)) - start)) - (map!- f l l)) - -(define (each f l) - (if (null? l) l - (begin (f (car l)) - (each f (cdr l))))) - -(define (maptree-pre f t) - (let ((new-t (f t))) - (if (pair? new-t) - (map (lambda (e) (maptree-pre f e)) new-t) - new-t))) - -(define (maptree-post f t) - (if (not (pair? t)) - (f t) - (let ((new-t (map (lambda (e) (maptree-post f e)) t))) - (f new-t)))) - -; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e) -(define (flatten-left-op op e) - (maptree-post (lambda (node) - (if (and (pair? node) - (eq? (car node) op) - (pair? (cdr node)) - (pair? (cadr node)) - (eq? (caadr node) op)) - (cons op - (append (cdadr node) (cddr node))) - node)) - e)) - -; convert all local variable references to (lexref rib slot name) -; where rib is the nesting level and slot is the stack slot# -; name is just there for reference -; this assumes lambda is the only remaining naming form -(define (lexical-var-conversion e) - (define (lookup-var v env lev) - (if (null? env) v - (let ((i (index-of v (car env) 0))) - (if i (list 'lexref lev i v) - (lookup-var v (cdr env) (+ lev 1)))))) - (define (lvc- e env) - (cond ((symbol? e) (lookup-var e env 0)) - ((pair? e) - (if (eq? (car e) 'quote) - e - (let* ((newvs (and (eq? (car e) 'lambda) (cadr e))) - (newenv (if newvs (cons newvs env) env))) - (if newvs - (cons 'lambda - (cons (cadr e) - (map (lambda (se) (lvc- se newenv)) - (cddr e)))) - (map (lambda (se) (lvc- se env)) e))))) - (else e))) - (lvc- e ())) - -; convert let to lambda -(define (let-expand e) - (maptree-post (lambda (n) - (if (and (pair? n) (eq? (car n) 'let)) - `((lambda ,(map car (cadr n)) ,@(cddr n)) - ,@(map cadr (cadr n))) - n)) - e)) diff --git a/femtolisp/ast/out.lsp b/femtolisp/ast/out.lsp deleted file mode 100644 index b389a4e..0000000 --- a/femtolisp/ast/out.lsp +++ /dev/null @@ -1 +0,0 @@ -'(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 "" (*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*))))) diff --git a/femtolisp/ast/plambda-js.scm b/femtolisp/ast/plambda-js.scm deleted file mode 100644 index ed9c066..0000000 --- a/femtolisp/ast/plambda-js.scm +++ /dev/null @@ -1,23 +0,0 @@ -; pattern-lambda syntax for jscheme - -; pattern-lambda abstraction -; this is a generalization of lambda: -; -; ((pattern-lambda p body) expr) -; Matches expr against p. If no match, return #null. If match succeeds, evaluate body -; with variables in p bound to whatever they matched in expr. -; -; EXAMPLE: Recognize adding any expression x to itself, replace with 2*x. -; (define selfadd (pattern-lambda (+ x x) `(* 2 ,x))) -; Then (selfadd '(+ (foo bar) (foo bar))) returns (* 2 (foo bar)) -; -(define-macro (pattern-lambda pat body) - (let* ((args (patargs pat)) - (expander `(lambda ,args ,body))) - `(lambda (expr) - (let ((m (match ',pat expr))) - (if m - ; matches; perform expansion - (apply ,expander (map (lambda (var) (cdr (or (assq var m) '(0 . #f)))) - ',args)) - #f))))) diff --git a/femtolisp/ast/rpasses.lsp b/femtolisp/ast/rpasses.lsp index a6faf91..a086a94 100644 --- a/femtolisp/ast/rpasses.lsp +++ b/femtolisp/ast/rpasses.lsp @@ -110,7 +110,7 @@ ;) (define (main) (progn - (define *input* (load "starpR.lsp")) + (define *input* (load "???.lsp")) ;(define t0 ((java.util.Date:new):getTime)) (time (compile-ish *input*)) ;(define t1 ((java.util.Date:new):getTime)) diff --git a/femtolisp/ast/rpasses.scm b/femtolisp/ast/rpasses.scm deleted file mode 100644 index 7168c6c..0000000 --- a/femtolisp/ast/rpasses.scm +++ /dev/null @@ -1,206 +0,0 @@ -(include "iscutil.scm") -(include "match.scm") -(include "asttools.scm") -;(load "plambda-js.scm") -;(load "plambda-chez.scm") - -;(pretty-print *input*) - -#| -Overall phases: -I. s-expr output -II. tree normalization - 1. control construct normalization, flattening. various restructuring. - 2. transformations that might add variables - 3. local variable detection -III. var/func attribute analysis -IV. argument normalization -V. type inference - 1. split each function into generic/non-generic versions. the generic - one resolves generic funcs to calls to a lookup routine that tries - to find stuff like `diag<-.darray`. the other one assumes everything - is handled by a builtin R function with a known t-function - 2. inference -VI. code generation - -Useful R lowering passes: - -- control construct normalization - . convert while/repeat/various for forms/break/next to while/break - . convert switch to nested if - -- local variable detection - . classify vars as (1) definitely local, (2) possibly-local, (3) free - . collect all local or possibly-local vars and wrap the body with - (let ((g0 (upvalue 'var1)) - (g1 (upvalue 'var2))) - ) - - where (upvalue x) is either (get-global x) or (captured-var n i) - for definitely-local, start as null instead of upvalue - - then we have to rename var1 to g0 everywhere inside that. - for the vast majority of functions that don't attempt to modify parent-scope - locals, pure-functional closure conversion would work. - - utility for this: fold-along-cfg - . after this the tree is ready for typical lexical scope analysis - - (- closure conversion/deBruijn indices) - -- argument normalization for call to known function - . convert lambda arglist to plain list of symbols - . move default initializers into body as `(when (eq? ,argname 'missing) ,assign) - . at call site sort args to correct positions, add explicit missing - . if call target unknown insert call to match.args or whatever - -- r-block, ||, && flattening - -- fancy assignment transformation: - f(v) <- rhs, (<- (r-call f v) rhs) - performs: - (begin (<- v (r-call f<- v rhs)) - rhs) - -- (<- a b) becomes (ref= a (lazy-copy b)) - arguments to functions are wrapped in lazy-copy at the call site, so we can - omit the copy (1) for functions marked as pass-by-ref, (2) where user indicated - pass-by-ref, (3) for arguments which are strictly-allocating expressions, - (4) for user functions proven to be ref-safe and thus marked as case (1) - -Useful analyses: - -- prove function strictness!! - . strict functions need to open with (if (promise? arg) (force arg) arg) for each - arg, in case they are called indirectly. -- prove global variables constant (esp. function names) - . prove builtins redefined/constant -- need dictionary of builtin properties (pure/strict/t-functions/etc.) -- useful but very general types: - single: has length 1 and no attrs (implies simple) - simple: has default class attributes - array: has dim attribute only - distributed: starp array - numeric -|# - - -(define missing-arg-tag '*r-missing*) - -; tree inspection utils - -(define (assigned-var e) - (and (pair? e) - (or (eq? (car e) '<-) (eq? (car e) 'ref=)) - (symbol? (cadr e)) - (cadr e))) - -(define (func-argnames f) - (let ((argl (cadr f))) - (if (eq? argl '*r-null*) () - (map cadr argl)))) - -; transformations - -(define (dollarsign-transform e) - (pattern-expand - (pattern-lambda ($ lhs name) - (let* ((g (if (not (pair? lhs)) lhs (gensym))) - (n (if (symbol? name) - (symbol->string name) - name)) - (expr `(r-call - r-aref ,g (index-in-strlist ,n (r-call attr ,g "names"))))) - (if (not (pair? lhs)) - expr - `(r-block (ref= ,g ,lhs) ,expr)))) - e)) - -; lower r expressions of the form f(lhs,...) <- rhs -; TODO: if there are any special forms that can be f in this expression, -; they need to be handled separately. For example a$b can be lowered -; to an index assignment (by dollarsign-transform), after which -; this transform applies. I don't think there are any others though. -(define (fancy-assignment-transform e) - (pattern-expand - (pattern-lambda (-$ (<- (r-call f lhs ...) rhs) - (<<- (r-call f lhs ...) rhs)) - (let ((g (if (pair? rhs) (gensym) rhs)) - (op (car __))) - `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ()) - (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g)) - ,g))) - e)) - -; map an arglist with default values to appropriate init code -; function(x=blah) { ... } gets -; if (missing(x)) x = blah -; added to its body -(define (gen-default-inits arglist) - (map (lambda (arg) - (let ((name (cadr arg)) - (default (caddr arg))) - `(when (missing ,name) - (<- ,name ,default)))) - (filter (lambda (arg) (not (eq? (caddr arg) missing-arg-tag))) arglist))) - -; convert r function expressions to lambda -(define (normalize-r-functions e) - (maptree-post (lambda (n) - (if (and (pair? n) (eq? (car n) 'function)) - `(lambda ,(func-argnames n) - (r-block ,@(gen-default-inits (cadr n)) - ,@(if (and (pair? (caddr n)) - (eq? (car (caddr n)) 'r-block)) - (cdr (caddr n)) - (list (caddr n))))) - n)) - e)) - -(define (find-assigned-vars n) - (let ((vars ())) - (maptree-pre (lambda (s) - (if (not (pair? s)) s - (cond ((eq? (car s) 'lambda) #f) - ((eq? (car s) '<-) - (set! vars (list-adjoin (cadr s) vars)) - (cddr s)) - (else s)))) - n) - vars)) - -; introduce let based on assignment statements -(define (letbind-locals e) - (maptree-post (lambda (n) - (if (and (pair? n) (eq? (car n) 'lambda)) - (let ((vars (find-assigned-vars (cddr n)))) - `(lambda ,(cadr n) (let ,(map list - vars - (map (lambda (x) '()) vars)) - ,@(cddr n)))) - n)) - e)) - -(define (compile-ish e) - (letbind-locals - (normalize-r-functions - (fancy-assignment-transform - (dollarsign-transform - (flatten-all-op && (flatten-all-op || e))))))) - -;(trace map) -;(pretty-print (compile-ish *input*)) -;(print -; (time-call (lambda () (compile-ish *input*)) 1) -;) -(define (main) - (begin - (define *input* (read)) - (define t0 ((java.util.Date:new):getTime)) - (compile-ish *input*) - (define t1 ((java.util.Date:new):getTime)) - (display "milliseconds: ") - (display (- t1 t0)) - (newline))) - -(main) diff --git a/femtolisp/ast/starpR.lsp b/femtolisp/ast/starpR.lsp deleted file mode 100644 index d0ce960..0000000 --- a/femtolisp/ast/starpR.lsp +++ /dev/null @@ -1,120 +0,0 @@ -'(r-expressions - (r-call library \M\A\S\S) - (r-call dyn.load "starp.so") - (<- ppcommand (function ((*named* ... *r-missing*)) (r-call .\Call "ppcommand" (r-call list r-dotdotdot)) ())) - (<- ppvcommand (function ((*named* va *r-missing*)) (r-call .\Call "ppcommand" va) ())) - (<- ppinvoke ppcommand) - (<- pploadconfig (function ((*named* fileName *r-missing*)) (r-call .\Call "pploadconfig" file\Name) ())) - (<- ppconnect (function ((*named* numProcs ()) (*named* machines ())) (r-call .\Call "ppconnect" (r-call list num\Procs machines)) ())) - (<- ppgetlogpath (function () (r-call .\Call "ppgetlogpath") ())) - (<- ppgetlog (function () (r-call .\Call "ppgetlog") ())) - (<- ppshowdashboard (function () (r-call .\Call "ppshowdashboard") ())) - (<- pphidedashboard (function () (r-call .\Call "pphidedashboard") ())) - (<- revealargs (function ((*named* dots *r-missing*)) (r-call .\Call "_revealArgs" dots) ())) - (<- listargs (function ((*named* ... *r-missing*)) (r-call revealargs (r-call get "...")) ())) - (<- ppping (function () (r-call ppcommand "ppping") ())) - (<- ppver (function () (r-call ppcommand "pp_ver") ())) - (<- \S\T\A\R\P\D\I\S\T "../../../linkdist") - (<- \S\T\A\R\P\P\L\A\T\F\O\R\M "ia32_linux") - (r-call .\Call "_setstarpdist" \S\T\A\R\P\D\I\S\T) - (r-call .\Call "_setstarpplat" \S\T\A\R\P\P\L\A\T\F\O\R\M) - (r-call pploadconfig (r-call paste \S\T\A\R\P\D\I\S\T "/config/starpd.properties" (*named* sep ""))) - (<- dimdis (function ((*named* v *r-missing*)) (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 (function ((*named* x *r-missing*)) (&& (&& (\|\| (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-call class p) (r-call c "dlayout" "numeric")) - (<- darray (function ((*named* id *r-missing*) (*named* shape *r-missing*) (*named* distribution *r-missing*) (*named* isreal *r-missing*)) (r-block (<- shape (r-call as.array shape)) (<- distribution (r-call + distribution 1)) (<- (r-call class shape) (r-call append "dlayoutn" (r-call to\String distribution) (r-call class shape))) (<- d (r-call list (*named* id id) (*named* shape shape) (*named* isreal isreal) (*named* logical *r-false*) () ())) (<- (r-call class d) "darray") d) ())) - (<- darraydist (function ((*named* da *r-missing*)) (r-call as.numeric (r-call r-aref (r-call class ($ da shape)) 2)) ())) - (<- is.darray (function ((*named* x *r-missing*)) (r-call == (r-call r-index (r-call class x) 1) "darray") ())) - (<- is.nd (function ((*named* x *r-missing*)) (r-call != (r-call length (r-call dim x)) 2) ())) - (<- is.darraynd (function ((*named* x *r-missing*)) (&& (r-call is.darray x) (r-call is.nd x)) ())) - (<- is.dlayout (function ((*named* x *r-missing*)) (r-call any (r-call == (r-call class x) "dlayout")) ())) - (<- vdim (function ((*named* x *r-missing*)) (if (r-call is.vector x) (r-call length x) (r-call dim x)) ())) - (<- \[\[.dlayoutn (<- \[.dlayoutn (function ((*named* dl *r-missing*) (*named* n *r-missing*)) (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-call class r) (r-call append "dlayoutn" (r-call to\String didi) (r-call class r))) (return r)))) ()))) - (<- print.darray (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (r-block (<- sh (r-call as.vector ($ d shape))) (<- 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 "" (*named* sep "")) (*named* quote *r-false*)) (r-call invisible d)) ())) - (<- validdist (function ((*named* dims *r-missing*) (*named* dd *r-missing*)) (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 (function ((*named* x *r-missing*)) ($ x shape) ())) - (<- dim<-.darray (function ((*named* x *r-missing*) (*named* value *r-missing*)) (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 ($ x shape)) 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 ($ d shape)) 2) (r-call ppcommand "ppdensend_clobber_singletons_and_demote" d)) d))) ())) - (<- length.darray (function ((*named* d *r-missing*)) (r-call prod ($ d shape)) ())) - (<- ppzeros (function ((*named* dims *r-missing*)) (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 (function ((*named* dims *r-missing*)) (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 (function ((*named* dims *r-missing*)) (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 (function ((*named* m *r-missing*) (*named* dist (r-call dimdis (r-call dim m))) (*named* allowScalar *r-false*)) (r-block (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 allow\Scalar (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 (<- ($ d logical) *r-true*)) d) ())) - (<- ppfront (function ((*named* da *r-missing*)) (r-block (if (r-call ! (r-call is.darray da)) (return da)) (if (r-call == (r-call length ($ da shape)) 2) (r-block (<- l (r-call ppcommand "ppdense_ppfront" da)) (if ($ da logical) (<- m (r-call as.logical (r-call r-aref l 1))) (<- m (r-call r-aref l 1))) (<- (r-call dim m) (r-call c (r-call r-aref l 2) (r-call r-aref l 3)))) (r-block (<- m (r-call ppcommand "ppdensend_ppfront" da)) (if ($ da logical) (<- m (r-call as.logical m))) (<- (r-call dim m) (r-call as.vector ($ da shape))))) m) ())) - (<- vector (function ((*named* mode "logical") (*named* length 0)) (r-call \Use\Method "vector" length) ())) - (<- vector.default (r-call .\Primitive "vector")) - (<- vector.dlayout (function ((*named* mode "logical") (*named* length 0)) (r-block (<- d (r-call ppzeros (r-call c 1 length))) (if (r-call == mode "logical") (<- ($ d logical) *r-true*)) d) ())) - (<- double (function ((*named* length 0)) (r-call vector "double" length) ())) - (<- logical (function ((*named* length 0)) (r-call vector "logical" length) ())) - (<- c (function ((*named* ... *r-missing*)) (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-call class v) (r-call append "dlayoutn" (r-call to\String i) (r-call class v))) (return v)))) v) ())) - (<- rep (function ((*named* x *r-missing*) (*named* times 1) (*named* length.out \N\A) (*named* each 1)) (r-block (if (r-call is.darray x) (r-block (<- (r-call dim x) (r-call c 1 (r-call length x))) (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-call dim out) (r-call length out)) (return out)) ())) - (<- globalbinding (function ((*named* sym *r-missing*)) (r-call eval (r-call as.name sym) (*named* envir (r-call globalenv))) ())) - (<- boundp (function ((*named* sym *r-missing*)) (return (r-call != (r-call class (r-call try (r-call globalbinding sym) (*named* silent *r-true*))) "try-error")) ())) - (<- redefining (function ((*named* sym *r-missing*)) (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 (function ((*named* data \N\A) (*named* dim (r-call length data)) (*named* dimnames ())) (r-block (<- 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 ($ data shape)))) (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 (function ((*named* data \N\A) (*named* nrow 1) (*named* ncol 1) (*named* byrow *r-false*) (*named* dimnames ())) (r-block (<- 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 (function ((*named* da *r-missing*)) (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 (function ((*named* n *r-missing*) (*named* min 0) (*named* max 1)) (r-block (if (r-call is.dlayout n) (r-call pprand n) (r-call .\Internal (r-call runif n min max)))) ())) - (r-call redefining diag) - (<- diag (function ((*named* da *r-missing*) (*named* nrow *r-missing*) (*named* ncol n)) (r-block (if (r-call is.darray da) (r-block (if (r-call == (r-call length ($ da shape)) 1) (r-block (<- da (r-call as.2d da)))) (if (r-call == (r-call length ($ da shape)) 2) (r-block (if (r-call == (r-call r-index ($ da shape) 1) 1) (return (r-call ppcommand "ppdense_diagv" da 0)) (if (r-call == (r-call r-index ($ da shape) 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 (function ((*named* code *r-missing*) (*named* scalarcode *r-missing*) (*named* bscalarcode *r-missing*) (*named* ndcode *r-missing*) (*named* a *r-missing*) (*named* b *r-missing*)) (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 (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 1 1 1 2 a b) ())) - (<- *.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 3 3 3 3 a b) ())) - (<- /.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 4 4 5 6 a b) ())) - (<- ^.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 7 10 11 19 a b) ())) - (<- mkdlogicalop (function ((*named* c *r-missing*) (*named* sc *r-missing*) (*named* bsc *r-missing*) (*named* ndcode *r-missing*)) (r-block (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (<- da (r-call dbinaryop c sc bsc ndcode a b)) (<- ($ da logical) *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 (function ((*named* a *r-missing*) (*named* b *r-missing*)) (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)) (<- ($ da logical) *r-true*) da) ())) - (<- \|.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (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)) (<- ($ da logical) *r-true*) da) ())) - (<- !.darray (function ((*named* a *r-missing*)) (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)))) (<- ($ da logical) *r-true*) da) ())) - (<- %*% (function ((*named* a *r-missing*) (*named* b *r-missing*)) (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 (function ((*named* a *r-missing*) (*named* b *r-missing*)) (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 (function ((*named* da *r-missing*) (*named* axis *r-missing*) (*named* allfunc *r-missing*) (*named* axisfunc *r-missing*) (*named* ndcode *r-missing*) (*named* islogical *r-false*)) (r-block (<- nd (r-call length ($ da shape))) (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-call dim da) (r-call length da)) (<- axis 1))) (<- res (r-call ppcommand "ppdensend_reduce" da ndcode (r-call - axis 1))) (if (&& islogical (r-call is.darray res)) (<- ($ res logical) *r-true*)) (return res)))) ())) - (<- any.darray (function ((*named* da *r-missing*) (*named* axis *r-false*) (*named* na.rm *r-false*)) (r-block (if (r-call == (r-call length ($ da shape)) 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 ($ da shape) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_any" da axis)) (<- ($ res logical) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 5 *r-true*)))) ())) - (<- all.darray (function ((*named* da *r-missing*) (*named* axis *r-false*) (*named* na.rm *r-false*)) (r-block (if (r-call == (r-call length ($ da shape)) 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 ($ da shape) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_all" da axis)) (<- ($ res logical) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 6 *r-true*)))) ())) - (<- sum (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- 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 (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- 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 (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- 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 (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- 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 (function ((*named* d *r-missing*) (*named* dist 2)) (r-block (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 (function ((*named* x *r-missing*)) (r-call as.array (r-call as.real x)) ())) - (<- as.1d (function ((*named* x *r-missing*)) (r-block (<- (r-call dim x) (r-call length x)) (return x)) ())) - (<- as.2d (function ((*named* x *r-missing*)) (r-block (<- (r-call dim x) (r-call c 1 (r-call length x))) (return x)) ())) - (<- as.real2d (function ((*named* x *r-missing*)) (r-block (<- x (r-call as.real x)) (<- (r-call dim x) (r-call c 1 (r-call length x))) (return x)) ())) - (<- to\Index\Vec2d (function ((*named* i *r-missing*) (*named* con *r-missing*)) (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*)))) ())) - (<- to\Index\Vec (function ((*named* i *r-missing*) (*named* con *r-missing*)) (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*)))) ())) - (<- to\Num\Index (function ((*named* i *r-missing*)) (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 ! ($ i logical)) (r-block (return i)))) (if (r-call != (r-call length (r-call dim i)) 2) (<- (r-call dim i) (r-call c 1 (r-call length i)))) (<- i (r-call r-aref (r-call ppcommand "ppdense_find" i 1 0 0) 1)) (<- (r-call dim i) (r-call length i)) i) ())) - (<- expand\Linear\Index (function ((*named* shape *r-missing*) (*named* i *r-missing*)) (r-block (<- out (r-call numeric (r-call length shape))) (for n (r-call : 1 (r-call length shape)) (r-block (<- (r-call r-aref out n) (r-call + (r-call %% (r-call - i 1) (r-call r-index shape n)) 1)) (<- i (r-call + (r-call %/% (r-call - i 1) (r-call r-index shape n)) 1)))) out) ())) - (<- to\Linear\Index (function ((*named* shape *r-missing*) (*named* iv *r-missing*)) (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) ())) - (<- to\Linear\Indexes (function ((*named* shape *r-missing*) (*named* im *r-missing*)) (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 (function ((*named* x *r-missing*)) (r-call identical x starpcolon) ())) - (<- normalize\Indexes (function ((*named* shape *r-missing*) (*named* idxs *r-missing*)) (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 to\Linear\Indexes 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) ($ i logical)))) (if (&& lg (r-call == li 1)) (<- i (r-call rep i (*named* length.out (r-call prod shape))))) (<- i (r-call to\Num\Index 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-call r-aref out n) i))) out) ())) - (<- index\Sizes (function ((*named* d *r-missing*) (*named* idxs *r-missing*)) (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-call r-index whichcolons i) *r-true*) (<- (r-call r-index lens i) (r-call r-index (r-call dim d) i))) (<- (r-call r-index lens i) (r-call length (r-call r-aref idxs i)))))) (r-call list lens whichcolons)) ())) - (<- \[.darray (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (r-block (<- n (r-call nargs)) (if (r-call == n 1) (return d)) (<- idxs (r-call normalize\Indexes (r-call dim d) (r-call revealargs (r-call get "...")))) (<- tmp (r-call index\Sizes 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-call dim slice) (r-call c (r-call length slice) 1)) (<- 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 (function ((*named* i *r-missing*)) (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-call r-aref al 2) 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 (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (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 normalize\Indexes (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 index\Sizes 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 (function ((*named* i *r-missing*)) (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-call r-aref al 2) d) (<- (r-call r-aref al (r-call length al)) 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 (function ((*named* code *r-missing*) (*named* oldf *r-missing*) (*named* ndname *r-missing*)) (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 ""))) (function ((*named* x *r-missing*)) (r-block (if (r-call is.darray x) (r-block (if (r-call == (r-call length ($ x shape)) 2) (r-call ppcommand "ppdense_unary_op" code x) (r-call ppcommand ndname x))) (r-call oldf x))) ())) (r-block (function ((*named* x *r-missing*)) (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 (function ((*named* m *r-missing*)) (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 (function ((*named* m *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* symmetric *r-missing*) (*named* only.values *r-false*) (*named* EISPACK *r-false*)) (r-block (if (r-call ! (r-call is.darray x)) (return (r-call \Reigen x symmetric only.values \E\I\S\P\A\C\K))) (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 ()) (*named* vectors ()))) (if only.values (r-block (<- ($ out values) (r-call t res))) (r-block (if (&& (r-call ! (missing symmetric)) symmetric) (r-block (<- ($ out values) (r-call t (r-call r-aref res 2)))) (r-block (<- ($ out values) (r-call diag (r-call r-aref res 2))))) (<- ($ out vectors) (r-call r-aref res 1)))) out) ())) - (r-call redefining apply) - (<- apply (function ((*named* d *r-missing*) (*named* axis *r-missing*) (*named* f *r-missing*)) (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<- (function ((*named* d *r-missing*) (*named* value *r-missing*)) (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) ())) - (<- engine\Arg (function ((*named* arg *r-missing*)) (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 (function ((*named* filename *r-missing*) (*named* name "")) (r-block (<- 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 (function ((*named* name *r-missing*)) (r-block (r-call ppcommand "ppemode2_evaluate" "c" "ppevalc_builtin:remove_module" 1 0 name) *r-true*) ())) - (<- pploadpackage (function ((*named* filename *r-missing*) (*named* name "") (*named* engine "")) (r-block (<- engine (r-call engine\Arg 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 (function ((*named* name *r-missing*) (*named* engine "")) (r-block (<- engine (r-call engine\Arg engine)) (if (r-call == engine "c") (r-call ppunloadcenginemodule name) (r-call ppcommand "ppbase_removeUserPackage" name)) *r-true*) ()))) diff --git a/llt/u8.txt b/llt/u8.txt deleted file mode 100644 index 09c3c39..0000000 --- a/llt/u8.txt +++ /dev/null @@ -1,19 +0,0 @@ -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов -% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка к -